diff --git a/components/elm/src/biogeophys/ActiveLayerMod.F90 b/components/elm/src/biogeophys/ActiveLayerMod.F90 index 803c57fd3c1e..ebc72104f101 100644 --- a/components/elm/src/biogeophys/ActiveLayerMod.F90 +++ b/components/elm/src/biogeophys/ActiveLayerMod.F90 @@ -15,6 +15,7 @@ module ActiveLayerMod use ColumnDataType , only : col_es, col_ws use LandunitType , only : lun_pp use landunit_varcon , only : ilowcenpoly, iflatcenpoly, ihighcenpoly + use timeinfoMod ! implicit none save @@ -23,12 +24,11 @@ module ActiveLayerMod ! !PUBLIC MEMBER FUNCTIONS: public:: alt_calc !----------------------------------------------------------------------- - + contains !----------------------------------------------------------------------- - subroutine alt_calc(num_soilc, filter_soilc, & - temperature_vars, canopystate_vars) + subroutine alt_calc(num_soilc, filter_soilc, canopystate_vars) ! ! !DESCRIPTION: ! define active layer thickness similarly to frost_table, except set as deepest thawed layer and define on nlevgrnd @@ -45,6 +45,7 @@ subroutine alt_calc(num_soilc, filter_soilc, & ! initialized to valid values, so I think this is okay. ! ! !USES: + !$acc routine seq use shr_const_mod , only : SHR_CONST_TKFRZ use elm_varpar , only : nlevgrnd use elm_time_manager , only : get_curr_date, get_step_size @@ -54,7 +55,6 @@ subroutine alt_calc(num_soilc, filter_soilc, & ! !ARGUMENTS: integer , intent(in) :: num_soilc ! number of soil columns in filter integer , intent(in) :: filter_soilc(:) ! filter for soil columns - type(temperature_type) , intent(in) :: temperature_vars type(canopystate_type) , intent(inout) :: canopystate_vars ! ! !LOCAL VARIABLES: @@ -94,9 +94,13 @@ subroutine alt_calc(num_soilc, filter_soilc, & ! on a set annual timestep, update annual maxima ! make this 1 January for NH columns, 1 July for SH columns - call get_curr_date(year, mon, day, sec) - dtime = get_step_size() - if ( (mon .eq. 1) .and. (day .eq. 1) .and. ( sec / dtime .eq. 1) ) then + ! call get_curr_date(year, mon, day, sec) + dtime = int(dtime_mod) + year = year_curr + mon = mon_curr + day = day_curr + sec = secs_curr + if ( (mon .eq. 1) .and. (day .eq. 1) .and. ( sec / int(dtime) .eq. 1) ) then do fc = 1,num_soilc c = filter_soilc(fc) g = col_pp%gridcell(c) diff --git a/components/elm/src/biogeophys/AerosolMod.F90 b/components/elm/src/biogeophys/AerosolMod.F90 index 81fc8d62abc5..7d6ee4562377 100644 --- a/components/elm/src/biogeophys/AerosolMod.F90 +++ b/components/elm/src/biogeophys/AerosolMod.F90 @@ -12,7 +12,7 @@ module AerosolMod use ColumnType , only : col_pp use ColumnDataType , only : col_ws, col_wf - use timeinfoMod + use timeinfoMod, only : dtime_mod ! ! !PUBLIC TYPES: implicit none @@ -38,7 +38,6 @@ subroutine AerosolMasses(bounds, num_on, filter_on, num_off, filter_off, aerosol ! (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) - !$acc routine seq ! !ARGUMENTS: type(bounds_type) , intent(in ) :: bounds integer , intent(in) :: num_on ! number of column filter-ON points @@ -48,10 +47,10 @@ subroutine AerosolMasses(bounds, num_on, filter_on, num_off, filter_off, aerosol type(aerosol_type) , intent(inout) :: aerosol_vars ! ! !LOCAL VARIABLES: - real(r8) :: dtime ! land model time step (sec) - integer :: g,l,c,j,fc ! indices + integer :: g,l,c,j,fc,snl_idx ! 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 + real(r8) :: sum_bc,sum_oc,sum_dst !----------------------------------------------------------------------- associate( & @@ -92,30 +91,22 @@ subroutine AerosolMasses(bounds, num_on, filter_on, num_off, filter_off, aerosol mss_cnc_dst4 => aerosol_vars%mss_cnc_dst4_col & ! Output: [real(r8) (:,:) ] mass concentration of dust species 4 (col,lyr) [kg/kg] ) - dtime = dtime_mod - - do fc = 1, num_on - c = filter_on(fc) - - ! Zero column-integrated aerosol mass before summation - mss_bc_col(c) = 0._r8 - mss_oc_col(c) = 0._r8 - mss_dst_col(c) = 0._r8 - + !$acc enter data create(sum_bc,sum_oc,sum_dst) + if (.not. use_firn_percolation_and_compaction) then + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1, 0 + do fc = 1, num_on + c = filter_on(fc) + ! layer mass of snow: + snowmass = h2osoi_ice(c,j) + h2osoi_liq(c,j) - ! layer mass of snow: - snowmass = h2osoi_ice(c,j) + h2osoi_liq(c,j) - - if (.not. use_firn_percolation_and_compaction) 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(c)+1) then if (do_capsnow(c)) then - snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice(c)*dtime)) + snowcap_scl_fct = snowmass / (snowmass + (qflx_snwcp_ice(c)*dtime_mod)) mss_bcpho(c,j) = mss_bcpho(c,j)*snowcap_scl_fct mss_bcphi(c,j) = mss_bcphi(c,j)*snowcap_scl_fct @@ -128,22 +119,28 @@ subroutine AerosolMasses(bounds, num_on, filter_on, num_off, filter_off, aerosol mss_dst4(c,j) = mss_dst4(c,j)*snowcap_scl_fct endif endif - endif + end do + end do + endif + + !$acc parallel loop independent gang vector collapse(2) default(present) + do j = -nlevsno+1, 0 + do fc = 1, num_on + c = filter_on(fc) - if (j >= snl(c)+1) then + ! layer mass of snow: + snowmass = h2osoi_ice(c,j) + h2osoi_liq(c,j) + if (j >= snl(c)+1) then mss_bctot(c,j) = mss_bcpho(c,j) + mss_bcphi(c,j) - mss_bc_col(c) = mss_bc_col(c) + mss_bctot(c,j) mss_cnc_bcphi(c,j) = mss_bcphi(c,j) / snowmass mss_cnc_bcpho(c,j) = mss_bcpho(c,j) / snowmass mss_octot(c,j) = mss_ocpho(c,j) + mss_ocphi(c,j) - mss_oc_col(c) = mss_oc_col(c) + mss_octot(c,j) mss_cnc_ocphi(c,j) = mss_ocphi(c,j) / snowmass mss_cnc_ocpho(c,j) = mss_ocpho(c,j) / snowmass mss_dsttot(c,j) = mss_dst1(c,j) + mss_dst2(c,j) + mss_dst3(c,j) + mss_dst4(c,j) - mss_dst_col(c) = mss_dst_col(c) + mss_dsttot(c,j) mss_cnc_dst1(c,j) = mss_dst1(c,j) / snowmass mss_cnc_dst2(c,j) = mss_dst2(c,j) / snowmass mss_cnc_dst3(c,j) = mss_dst3(c,j) / snowmass @@ -176,50 +173,81 @@ subroutine AerosolMasses(bounds, num_on, filter_on, num_off, filter_off, aerosol mss_cnc_dst4(c,j) = 0._r8 endif enddo + enddo + !$acc parallel loop independent gang vector default(present) + do fc = 1, num_on + c = filter_on(fc) + snl_idx = snl(c)+1 ! top-layer diagnostics - h2osno_top(c) = h2osoi_ice(c,snl(c)+1) + h2osoi_liq(c,snl(c)+1) !TODO MV - is this correct to be placed here??? - mss_bc_top(c) = mss_bctot(c,snl(c)+1) - mss_oc_top(c) = mss_octot(c,snl(c)+1) - mss_dst_top(c) = mss_dsttot(c,snl(c)+1) - enddo + h2osno_top(c) = h2osoi_ice(c,snl_idx) + h2osoi_liq(c,snl_idx) !TODO MV - is this correct to be placed here??? + mss_bc_top(c) = mss_bctot(c,snl_idx) + mss_oc_top(c) = mss_octot(c,snl_idx) + mss_dst_top(c) = mss_dsttot(c,snl_idx) + end do - ! Zero mass variables in columns without snow + !$acc parallel loop gang worker independent default(present) private(sum_bc,sum_oc,sum_dst) + do fc = 1, num_on + c = filter_on(fc) + sum_bc = 0._r8 + sum_oc = 0._r8 + sum_dst = 0._r8 + !$acc loop vector reduction(+:sum_bc,sum_oc,sum_dst) + do j = -nlevsno+1,0 + if (j >= snl(c)+1) then + sum_bc = sum_bc + mss_bctot(c,j) + sum_oc = sum_oc + mss_octot(c,j) + sum_dst = sum_dst + mss_dsttot(c,j) + end if + end do + mss_bc_col(c) = sum_bc + mss_oc_col(c) = sum_oc + mss_dst_col(c) = sum_dst + end do + ! Zero mass variables in columns without snow + !$acc parallel loop independent gang vector default(present) do fc = 1, num_off c = filter_off(fc) - mss_bc_top(c) = 0._r8 mss_bc_col(c) = 0._r8 - mss_bcpho(c,:) = 0._r8 - mss_bcphi(c,:) = 0._r8 - mss_bctot(c,:) = 0._r8 - mss_cnc_bcphi(c,:) = 0._r8 - mss_cnc_bcpho(c,:) = 0._r8 mss_oc_top(c) = 0._r8 mss_oc_col(c) = 0._r8 - mss_ocpho(c,:) = 0._r8 - mss_ocphi(c,:) = 0._r8 - mss_octot(c,:) = 0._r8 - mss_cnc_ocphi(c,:) = 0._r8 - mss_cnc_ocpho(c,:) = 0._r8 mss_dst_top(c) = 0._r8 mss_dst_col(c) = 0._r8 - mss_dst1(c,:) = 0._r8 - mss_dst2(c,:) = 0._r8 - mss_dst3(c,:) = 0._r8 - mss_dst4(c,:) = 0._r8 - mss_dsttot(c,:) = 0._r8 - - mss_cnc_dst1(c,:) = 0._r8 - mss_cnc_dst2(c,:) = 0._r8 - mss_cnc_dst3(c,:) = 0._r8 - mss_cnc_dst4(c,:) = 0._r8 - enddo + !$acc parallel loop independent gang vector collapse(2) default(present) + do j=-nlevsno+1,0 + do fc = 1, num_off + c = filter_off(fc) + mss_dst1(c,j) = 0._r8 + mss_dst2(c,j) = 0._r8 + mss_dst3(c,j) = 0._r8 + mss_dst4(c,j) = 0._r8 + mss_dsttot(c,j) = 0._r8 + + mss_cnc_dst1(c,j) = 0._r8 + mss_cnc_dst2(c,j) = 0._r8 + mss_cnc_dst3(c,j) = 0._r8 + mss_cnc_dst4(c,j) = 0._r8 + mss_ocpho(c,j) = 0._r8 + mss_ocphi(c,j) = 0._r8 + mss_octot(c,j) = 0._r8 + mss_cnc_ocphi(c,j) = 0._r8 + mss_cnc_ocpho(c,j) = 0._r8 + + mss_bcpho(c,j) = 0._r8 + mss_bcphi(c,j) = 0._r8 + mss_bctot(c,j) = 0._r8 + mss_cnc_bcphi(c,j) = 0._r8 + mss_cnc_bcpho(c,j) = 0._r8 + end do + end do + !$acc exit data delete(sum_bc,sum_oc,sum_dst) + end associate end subroutine AerosolMasses @@ -230,7 +258,6 @@ subroutine AerosolFluxes(bounds, num_snowc, filter_snowc, & ! ! !DESCRIPTION: ! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere - !$acc routine seq ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_snowc ! number of snow points in column filter @@ -239,7 +266,6 @@ subroutine AerosolFluxes(bounds, num_snowc, filter_snowc, & type(aerosol_type) , intent(inout) :: aerosol_vars ! ! !LOCAL VARIABLES: - real(r8) :: dtime ! land model time step (sec) integer :: c,g,j,fc !----------------------------------------------------------------------- @@ -289,6 +315,8 @@ subroutine AerosolFluxes(bounds, num_snowc, filter_snowc, & ! (cloud-borne) aerosol, and "pho" flavors are interstitial ! aerosol. "wet" and "dry" fluxes of BC and OC specified here are ! purely diagnostic + + !$acc parallel loop independent gang vector default(present) do c = bounds%begc,bounds%endc g = col_pp%gridcell(c) @@ -324,6 +352,7 @@ subroutine AerosolFluxes(bounds, num_snowc, filter_snowc, & ! species are distinguished in model, other fluxes (e.g., dry and ! wet BC/OC) are purely diagnostic. + !$acc parallel loop independent gang vector default(present) do c = bounds%begc,bounds%endc g = col_pp%gridcell(c) @@ -359,19 +388,20 @@ subroutine AerosolFluxes(bounds, num_snowc, filter_snowc, & ! is in the top layer after deposition, and is not immediately ! washed out before radiative calculations are done - dtime = dtime_mod - + !$acc parallel loop independent gang vector default(present) & + !$acc present(mss_bcphi(:,:),mss_bcpho(:,:),mss_ocphi(:,:),mss_ocpho(:,:), & + !$acc mss_dst1(:,:),mss_dst2(:,:),mss_dst3(:,:),mss_dst4(:,:)) do fc = 1, num_snowc c = filter_snowc(fc) - mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime) - mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime) - mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime) - mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime) - - mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime - mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime - mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime - mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime + mss_bcphi(c,snl(c)+1) = mss_bcphi(c,snl(c)+1) + (flx_bc_dep_phi(c)*dtime_mod) + mss_bcpho(c,snl(c)+1) = mss_bcpho(c,snl(c)+1) + (flx_bc_dep_pho(c)*dtime_mod) + mss_ocphi(c,snl(c)+1) = mss_ocphi(c,snl(c)+1) + (flx_oc_dep_phi(c)*dtime_mod) + mss_ocpho(c,snl(c)+1) = mss_ocpho(c,snl(c)+1) + (flx_oc_dep_pho(c)*dtime_mod) + + mss_dst1(c,snl(c)+1) = mss_dst1(c,snl(c)+1) + (flx_dst_dep_dry1(c) + flx_dst_dep_wet1(c))*dtime_mod + mss_dst2(c,snl(c)+1) = mss_dst2(c,snl(c)+1) + (flx_dst_dep_dry2(c) + flx_dst_dep_wet2(c))*dtime_mod + mss_dst3(c,snl(c)+1) = mss_dst3(c,snl(c)+1) + (flx_dst_dep_dry3(c) + flx_dst_dep_wet3(c))*dtime_mod + mss_dst4(c,snl(c)+1) = mss_dst4(c,snl(c)+1) + (flx_dst_dep_dry4(c) + flx_dst_dep_wet4(c))*dtime_mod end do end associate diff --git a/components/elm/src/biogeophys/BalanceCheckMod.F90 b/components/elm/src/biogeophys/BalanceCheckMod.F90 index f46091972852..f2ef6c832dd9 100644 --- a/components/elm/src/biogeophys/BalanceCheckMod.F90 +++ b/components/elm/src/biogeophys/BalanceCheckMod.F90 @@ -26,7 +26,6 @@ module BalanceCheckMod use ColumnDataType , only : col_ef, col_ws, col_wf use VegetationType , only : veg_pp use VegetationDataType , only : veg_ef, veg_ws - use timeinfoMod ! ! !PUBLIC TYPES: @@ -364,7 +363,6 @@ subroutine ColWaterBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & do fc = 1,num_do_smb_c c = filter_do_smb_c(fc) g = col_pp%gridcell(c) -! write(iulog,*)'WARNING: glc_dyn_runoff_routing = ', glc_dyn_runoff_routing(g) ! TKT if (glc_dyn_runoff_routing(g)) then errh2o(c) = errh2o(c) + qflx_glcice_frz(c)*dtime errh2o(c) = errh2o(c) - qflx_glcice_melt(c)*dtime @@ -391,7 +389,7 @@ subroutine ColWaterBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & if ((col_pp%itype(indexc) == icol_roof .or. & col_pp%itype(indexc) == icol_road_imperv .or. & col_pp%itype(indexc) == icol_road_perv) .and. & - abs(errh2o(indexc)) > 1.e-4_r8 .and. (nstep > 2) ) then + abs(errh2o(indexc)) > 1.e-4_r8 ) then write(iulog,*)'clm urban model is stopping - error is greater than 1e-4 (mm)' write(iulog,*)'nstep = ',nstep @@ -416,7 +414,7 @@ subroutine ColWaterBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & write(iulog,*)'elm model is stopping' call endrun(decomp_index=indexc, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) - else if (abs(errh2o(indexc)) > 1.e-4_r8 .and. (nstep > 2) ) then + else if (abs(errh2o(indexc)) > 1.e-4_r8 ) then write(iulog,*)'elm model is stopping - error is greater than 1e-4 (mm)' write(iulog,*)'colum number = ',col_pp%gridcell(indexc) @@ -702,6 +700,9 @@ subroutine ColWaterBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & write(iulog,*)'WARNING: BalanceCheck: longwave energy balance error (W/m2)' write(iulog,*)'nstep = ',nstep write(iulog,*)'errlon = ',errlon(indexp) + write(iulog,*) "lwrad_out:",eflx_lwrad_out(indexp) + write(iulog,*) "lwrad_net: ",eflx_lwrad_net(indexp) + write(iulog,*) "forc_lwrad:", forc_lwrad(veg_pp%topounit(indexp)) if (abs(errlon(indexp)) > 1.e-5_r8 ) then write(iulog,*)'elm model is stopping - error is greater than 1e-5 (W/m2)' call endrun(decomp_index=indexp, elmlevel=namep, msg=errmsg(__FILE__, __LINE__)) @@ -767,8 +768,9 @@ subroutine ColWaterBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & write(iulog,*)'WARNING: BalanceCheck: soil balance error (W/m2)' write(iulog,*)'nstep = ',nstep write(iulog,*)'errsoi_col = ',errsoi_col(indexc) - write(iulog,*)'colum number = ',col_pp%gridcell(indexc) - if (abs(errsoi_col(indexc)) > 1.e-4_r8 .and. (nstep > 2) ) then + write(iulog,*)'gridcell number = ',col_pp%gridcell(indexc) + write(iulog,*)'itype = ',col_pp%itype(indexc) + if (abs(errsoi_col(indexc)) > 1.e-4_r8 .and. (nstep > 2) ) then write(iulog,*)'elm model is stopping' call endrun(decomp_index=indexc, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) end if @@ -788,7 +790,7 @@ subroutine BeginGridWaterBalance(bounds, & ! Initialize column-level water balance at beginning of time step ! ! !USES: - use subgridAveMod , only : p2c,c2g, urbanf, unity + use subgridAveMod , only : p2c_1d_filter, c2g_1d_parallel, urbanf, unity use elm_varpar , only : nlevgrnd, nlevsoi, nlevurb use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use column_varcon , only : icol_road_perv, icol_road_imperv @@ -805,12 +807,14 @@ subroutine BeginGridWaterBalance(bounds, & ! ! !LOCAL VARIABLES: integer :: c, p, f, j, fc,g ! indices + integer :: begc, endc, begp, endp real(r8) :: h2osoi_vol real(r8) :: h2ocan_col(bounds%begc:bounds%endc) real(r8) :: begwb_col (bounds%begc:bounds%endc) real(r8) :: h2osoi_liq_depth_intg(bounds%begc:bounds%endc) real(r8) :: h2osoi_ice_depth_intg(bounds%begc:bounds%endc) real(r8) :: wa_local_col(bounds%begc:bounds%endc) + real(r8) :: sum1,sum2,sum3 associate( & zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) @@ -834,22 +838,32 @@ subroutine BeginGridWaterBalance(bounds, & ) ! Set to zero - begwb_col (bounds%begc:bounds%endc) = 0._r8 - h2ocan_col(bounds%begc:bounds%endc) = 0._r8 - h2osoi_liq_depth_intg(bounds%begc:bounds%endc) = 0._r8 - h2osoi_ice_depth_intg(bounds%begc:bounds%endc) = 0._r8 - h2osoi_liq_depth_intg_col(bounds%begc:bounds%endc) = 0._r8 - h2osoi_ice_depth_intg_col(bounds%begc:bounds%endc) = 0._r8 + !$acc enter data create( & + !$acc begwb_col (:), & + !$acc h2ocan_col(:), & + !$acc h2osoi_liq_depth_intg(:), & + !$acc h2osoi_ice_depth_intg(:), & + !$acc wa_local_col(:), sum1,sum2,sum3 & + !$acc ) + + begc = bounds%begc + endc = bounds%endc + begp = bounds%begp + endp = bounds%endp + !$acc parallel loop independent gang vector default(present) + do c = begc, endc + h2osoi_liq_depth_intg_col(c) = 0._r8 + h2osoi_ice_depth_intg_col(c) = 0._r8 + wa_local_col(c) = wa(c) + end do ! Determine beginning water balance for time step ! pft-level canopy water averaged to column + call p2c_1d_filter(bounds,num_nolakec,filter_nolakec, & + h2ocan_patch(begp:endp), & + h2ocan_col(begc:endc)) - call p2c(bounds, num_nolakec, filter_nolakec, & - h2ocan_patch(bounds%begp:bounds%endp), & - h2ocan_col(bounds%begc:bounds%endc)) - - wa_local_col(bounds%begc:bounds%endc) = wa(bounds%begc:bounds%endc) - + !$acc parallel loop independent gang vector default(present) do f = 1, num_nolakec c = filter_nolakec(f) g = col_pp%gridcell(c) @@ -863,65 +877,85 @@ subroutine BeginGridWaterBalance(bounds, & begwb_col(c) = begwb_col(c) + total_plant_stored_h2o(c) end do - do j = 1, nlevgrnd - do f = 1, num_nolakec - c = filter_nolakec(f) + !$acc parallel loop independent gang worker default(present) private(c,sum1,sum2) + do f = 1, num_nolakec + sum1 = 0._r8 + sum2 = 0._r8 + c = filter_nolakec(f) + !$acc loop reduction(+:sum1,sum2) + do j = 1, nlevgrnd if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & .or. col_pp%itype(c) == icol_roof) .and. j > nlevurb) then else - begwb_col(c) = begwb_col(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + h2osoi_liq(c,j) - h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + h2osoi_ice(c,j) + sum1 = sum1 + h2osoi_liq(c,j) + sum2 = sum2 + h2osoi_ice(c,j) end if end do + begwb_col(c) = begwb_col(c) + sum1 + sum2 + h2osoi_liq_depth_intg(c) = sum1 + h2osoi_ice_depth_intg(c) = sum2 end do - + + !$acc parallel loop independent gang worker default(present) private(c,sum1,sum2) do f = 1, num_lakec c = filter_lakec(f) + sum1 = 0._r8 ; sum2 = 0._r8 begwb_col(c) = h2osno(c) + !$acc loop reduction(+:sum1,sum2,sum3) do j = 1, nlevgrnd - begwb_col(c) = begwb_col(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + h2osoi_liq(c,j) - h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + h2osoi_ice(c,j) + sum1 = sum1 + h2osoi_liq(c,j) + sum2 = sum2 + h2osoi_ice(c,j) enddo + begwb_col(c) = begwb_col(c) + sum1 +sum2 + h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + sum1 + h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + sum2 + end do - call c2g(bounds, begwb_col(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, begwb_col(bounds%begc:bounds%endc), & begwb_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true.) - call c2g(bounds, wa_local_col(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, wa_local_col(bounds%begc:bounds%endc), & beg_wa_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) - call c2g(bounds, h2ocan_col(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, h2ocan_col(bounds%begc:bounds%endc), & beg_h2ocan_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) - call c2g(bounds, h2osno(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, h2osno(bounds%begc:bounds%endc), & beg_h2osno_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) - call c2g(bounds, h2osfc(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, h2osfc(bounds%begc:bounds%endc), & beg_h2osfc_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) - call c2g(bounds, h2osoi_liq_depth_intg(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, h2osoi_liq_depth_intg(bounds%begc:bounds%endc), & beg_h2osoi_liq_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) - call c2g(bounds, h2osoi_ice_depth_intg(bounds%begc:bounds%endc), & + call c2g_1d_parallel(bounds, h2osoi_ice_depth_intg(bounds%begc:bounds%endc), & beg_h2osoi_ice_grc(bounds%begg:bounds%endg), & - c2l_scale_type= urbanf, l2g_scale_type=unity ) - + c2l_scale_type= urbanf, l2g_scale_type=unity,para=.true. ) + + !$acc exit data delete( & + !$acc begwb_col (:), & + !$acc h2ocan_col(:), & + !$acc h2osoi_liq_depth_intg(:), & + !$acc h2osoi_ice_depth_intg(:), & + !$acc wa_local_col(:),sum1,sum2,sum3 & + !$acc ) + end associate end subroutine BeginGridWaterBalance !----------------------------------------------------------------------- - subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & - atm2lnd_vars, glc2lnd_vars, solarabs_vars, & - energyflux_vars, canopystate_vars, soilhydrology_vars) + subroutine GridBalanceCheck( bounds, & + atm2lnd_vars, glc2lnd_vars, & + energyflux_vars, soilhydrology_vars) ! ! !DESCRIPTION: ! @@ -931,19 +965,14 @@ subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & use column_varcon , only : icol_road_perv, icol_road_imperv use landunit_varcon , only : istice_mec, istdlak, istsoil,istcrop,istwet use elm_varctl , only : create_glacier_mec_landunit - use elm_initializeMod , only : surfalb_vars use CanopyStateType , only : canopystate_type use subgridAveMod , only : c2g, urbanf, unity ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_do_smb_c ! number of columns in filter_do_smb_c - integer , intent(in) :: filter_do_smb_c (:) ! column filter for points where SMB calculations are done type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(glc2lnd_type) , intent(in) :: glc2lnd_vars - type(solarabs_type) , intent(in) :: solarabs_vars type(energyflux_type) , intent(inout) :: energyflux_vars - type(canopystate_type), intent(inout) :: canopystate_vars type(soilhydrology_type), intent(inout) :: soilhydrology_vars ! ! !LOCAL VARIABLES: @@ -963,7 +992,6 @@ subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & forc_lwrad => atm2lnd_vars%forc_lwrad_downscaled_col , & ! Input: [real(r8) (:) ] downward infrared (longwave) radiation (W/m**2) glc_dyn_runoff_routing => glc2lnd_vars%glc_dyn_runoff_routing_grc , & ! Input: [real(r8) (:) ] whether we're doing runoff routing appropriate for having a dynamic icesheet - do_capsnow => col_ws%do_capsnow , & ! Input: [logical (:) ] true => do snow capping h2osno_col => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) h2osno_old => col_ws%h2osno_old , & ! Input: [real(r8) (:) ] snow water (mm H2O) at previous time step frac_sno_eff => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] effective snow fraction @@ -976,7 +1004,6 @@ subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & endwb_col => col_ws%endwb , & ! Output: [real(r8) (:) ] water mass end of the time step endwb_grc => grc_ws%endwb , & ! Output: [real(r8) (:) ] water mass end of the time step total_plant_stored_h2o_col => col_ws%total_plant_stored_h2o , & ! Input: [real(r8) (:) ] water mass in plant tissues (kg m-2) - dwb => col_wf%dwb , & ! Output: [real(r8) (:) ] change of water mass within the time step [kg/m2/s] qflx_rain_grnd_col => col_wf%qflx_rain_grnd , & ! Input: [real(r8) (:) ] rain on ground after interception (mm H2O/s) [+] qflx_snow_grnd_col => col_wf%qflx_snow_grnd , & ! Input: [real(r8) (:) ] snow on ground after interception (mm H2O/s) [+] qflx_evap_soi => col_wf%qflx_evap_soi , & ! Input: [real(r8) (:) ] soil evaporation (mm H2O/s) (+ = to atm) @@ -1004,50 +1031,8 @@ subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & qflx_glcice => col_wf%qflx_glcice , & ! Input: [real(r8) (:) ] flux of new glacier ice (mm H2O /s) [+ if ice grows] qflx_glcice_melt => col_wf%qflx_glcice_melt , & ! Input: [real(r8) (:) ] ice melt (mm H2O/s) qflx_glcice_frz => col_wf%qflx_glcice_frz , & ! Input: [real(r8) (:) ] ice growth (mm H2O/s) [+] - qflx_top_soil => col_wf%qflx_top_soil , & ! Input: [real(r8) (:) ] net water input into soil from top (mm/s) - qflx_sl_top_soil => col_wf%qflx_sl_top_soil , & ! Input: [real(r8) (:) ] liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) - qflx_liq_dynbal => grc_wf%qflx_liq_dynbal , & ! Input: [real(r8) (:) ] liq runoff due to dynamic land cover change (mm H2O /s) - qflx_ice_dynbal => grc_wf%qflx_ice_dynbal , & ! Input: [real(r8) (:) ] ice runoff due to dynamic land cover change (mm H2O /s) - snow_sources => col_wf%snow_sources , & ! Output: [real(r8) (:) ] snow sources (mm H2O /s) - snow_sinks => col_wf%snow_sinks , & ! Output: [real(r8) (:) ] snow sinks (mm H2O /s) qflx_lateral => col_wf%qflx_lateral , & ! Input: [real(r8) (:) ] lateral flux of water to neighboring column (mm H2O /s) - - eflx_lwrad_out => veg_ef%eflx_lwrad_out , & ! Input: [real(r8) (:) ] emitted infrared (longwave) radiation (W/m**2) - eflx_lwrad_net => veg_ef%eflx_lwrad_net , & ! Input: [real(r8) (:) ] net infrared (longwave) rad (W/m**2) [+ = to atm] - eflx_sh_tot => veg_ef%eflx_sh_tot , & ! Input: [real(r8) (:) ] total sensible heat flux (W/m**2) [+ to atm] - eflx_lh_tot => veg_ef%eflx_lh_tot , & ! Input: [real(r8) (:) ] total latent heat flux (W/m8*2) [+ to atm] - eflx_soil_grnd => veg_ef%eflx_soil_grnd , & ! Input: [real(r8) (:) ] soil heat flux (W/m**2) [+ = into soil] - eflx_wasteheat_patch => veg_ef%eflx_wasteheat , & ! Input: [real(r8) (:) ] sensible heat flux from urban heating/cooling sources of waste heat (W/m**2) - eflx_heat_from_ac_patch => veg_ef%eflx_heat_from_ac , & ! Input: [real(r8) (:) ] sensible heat flux put back into canyon due to removal by AC (W/m**2) - eflx_traffic_patch => veg_ef%eflx_traffic , & ! Input: [real(r8) (:) ] traffic sensible heat flux (W/m**2) - eflx_dynbal => grc_ef%eflx_dynbal , & ! Input: [real(r8) (:) ] energy conversion flux due to dynamic land cover change(W/m**2) [+ to atm] - - sabg_soil => solarabs_vars%sabg_soil_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by soil (W/m**2) - sabg_snow => solarabs_vars%sabg_snow_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by snow (W/m**2) - sabg_chk => solarabs_vars%sabg_chk_patch , & ! Input: [real(r8) (:) ] sum of soil/snow using current fsno, for balance check - fsa => solarabs_vars%fsa_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed (total) (W/m**2) - fsr => solarabs_vars%fsr_patch , & ! Input: [real(r8) (:) ] solar radiation reflected (W/m**2) - sabv => solarabs_vars%sabv_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by vegetation (W/m**2) - sabg => solarabs_vars%sabg_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by ground (W/m**2) - errsoi_col => col_ef%errsoi , & ! Output: [real(r8) (:) ] column-level soil/lake energy conservation error (W/m**2) - errsol => veg_ef%errsol , & ! Output: [real(r8) (:) ] solar radiation conservation error (W/m**2) - errseb => veg_ef%errseb , & ! Output: [real(r8) (:) ] surface energy conservation error (W/m**2) - errlon => veg_ef%errlon , & ! Output: [real(r8) (:) ] longwave radiation conservation error (W/m**2) - - fabd => surfalb_vars%fabd_patch , & ! Input: [real(r8) (:,:)] flux absorbed by canopy per unit direct flux - fabi => surfalb_vars%fabi_patch , & ! Input: [real(r8) (:,:)] flux absorbed by canopy per unit indirect flux - elai => canopystate_vars%elai_patch , & ! Input: [real(r8) (:,:)] - esai => canopystate_vars%esai_patch , & ! Input: [real(r8) (:,:)] - - albd => surfalb_vars%albd_patch , & ! Output: [real(r8) (:,:)] surface albedo (direct) - albi => surfalb_vars%albi_patch , & ! Output: [real(r8) (:,:)] surface albedo (diffuse) - ftdd => surfalb_vars%ftdd_patch , & ! Input: [real(r8) (:,:)] down direct flux below canopy per unit direct flux - ftid => surfalb_vars%ftid_patch , & ! Input: [real(r8) (:,:)] down diffuse flux below canopy per unit direct flux - ftii => surfalb_vars%ftii_patch , & ! Input: [real(r8) (:,:)] down diffuse flux below canopy per unit diffuse flux - - netrad => veg_ef%netrad , & ! Output: [real(r8) (:) ] net radiation (positive downward) (W/m**2) - h2ocan_patch => veg_ws%h2ocan , & ! Input: [real(r8) (:) ] canopy water (mm H2O) (pft-level) wa => soilhydrology_vars%wa_col , & ! Output: [real(r8) (:) ] water in the unconfined aquifer (mm) h2ocan_col => col_ws%h2ocan , & ! Input: [real(r8) (:) ] canopy water (mm H2O) h2osfc_col => col_ws%h2osfc , & ! Input: [real(r8) (:) ] surface water (mm) @@ -1070,8 +1055,8 @@ subroutine GridBalanceCheck( bounds, num_do_smb_c, filter_do_smb_c, & l = col_pp%landunit(c) if (col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall) then - forc_rain_col(c) = 0. - forc_snow_col(c) = 0. + forc_rain_col(c) = 0._r8 + forc_snow_col(c) = 0._r8 else forc_rain_col(c) = forc_rain(c) forc_snow_col(c) = forc_snow(c) diff --git a/components/elm/src/biogeophys/BandDiagonalMod.F90 b/components/elm/src/biogeophys/BandDiagonalMod.F90 index b3283b6fdef4..05de02e06189 100644 --- a/components/elm/src/biogeophys/BandDiagonalMod.F90 +++ b/components/elm/src/biogeophys/BandDiagonalMod.F90 @@ -24,41 +24,31 @@ module BandDiagonalMod contains !----------------------------------------------------------------------- - subroutine BandDiagonal(bounds, lbj, ubj, jtop, jbot, numf, filter, nband, b, r, u) + subroutine BandDiagonal(bounds, lbj, ubj, jtop, jbot, numf, filter, b, r, u) ! ! !DESCRIPTION: ! Tridiagonal matrix solution - ! - ! !ARGUMENTS: + use lapack_acc_seq implicit none - type(bounds_type), intent(in) :: bounds + type(bounds_type), intent(in) :: bounds integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices - integer , intent(in) :: jtop( bounds%begc: ) ! top level for each column [col] + integer , intent(in) :: jtop(bounds%begc:) integer , intent(in) :: jbot( bounds%begc: ) ! bottom level for each column [col] integer , intent(in) :: numf ! filter dimension - integer , intent(in) :: nband ! band width integer , intent(in) :: filter(:) ! filter real(r8), intent(in) :: b( bounds%begc: , 1: , lbj: ) ! compact band matrix [col, nband, j] real(r8), intent(in) :: r( bounds%begc: , lbj: ) ! "r" rhs of linear system [col, j] real(r8), intent(inout) :: u( bounds%begc: , lbj: ) ! solution [col, j] ! ! ! LOCAL VARIABLES: - integer :: j,ci,fc,info,m,n !indices - integer :: kl,ku !number of sub/super diagonals - integer, allocatable :: ipiv(:) !temporary - real(r8),allocatable :: ab(:,:),temp(:,:) !compact storage array - real(r8),allocatable :: result(:) + integer , parameter :: nband = 5 ! band width + integer :: j,ci,fc,info,n,nmax, k,jstart,jstop !indices + integer, parameter :: kl=(nband-1)/2,ku=kl !number of sub/super diagonals + integer, parameter :: m=2*kl+ku+1 + real(r8),allocatable :: ab(:,:,:),temp(:,:,:) !compact storage array + real(r8),allocatable :: result(:,:) !----------------------------------------------------------------------- - - ! Enforce expected array sizes - SHR_ASSERT_ALL((ubound(jtop) == (/bounds%endc/)), errMsg(__FILE__, __LINE__)) - SHR_ASSERT_ALL((ubound(jbot) == (/bounds%endc/)), errMsg(__FILE__, __LINE__)) - SHR_ASSERT_ALL((ubound(b) == (/bounds%endc, nband, ubj/)), errMsg(__FILE__, __LINE__)) - SHR_ASSERT_ALL((ubound(r) == (/bounds%endc, ubj/)), errMsg(__FILE__, __LINE__)) - SHR_ASSERT_ALL((ubound(u) == (/bounds%endc, ubj/)), errMsg(__FILE__, __LINE__)) - - !!$ SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) !!$* !!$* -- LAPACK driver routine (version 3.1) -- @@ -155,67 +145,112 @@ subroutine BandDiagonal(bounds, lbj, ubj, jtop, jbot, numf, filter, nband, b, r, !!$* + need not be set on entry, but are required by the routine to store !!$* elements of U because of fill-in resulting from the row interchanges. - !Set up input matrix AB -!An m-by-n band matrix with kl subdiagonals and ku superdiagonals -!may be stored compactly in a two-dimensional array with +!An m-by-n band matrix with kl subdiagonals and ku superdiagonals +!may be stored compactly in a two-dimensional array with !kl+ku+1 rows and n columns !AB(KL+KU+1+i-j,j) = A(i,j) - do fc = 1,numf - ci = filter(fc) - - kl=(nband-1)/2 - ku=kl -! m is the number of rows required for storage space by dgbsv - m=2*kl+ku+1 -! n is the number of levels (snow/soil) -!scs: replace ubj with jbot - n=jbot(ci)-jtop(ci)+1 - - allocate(ab(m,n)) - ab=0.0 - - ab(kl+ku-1,3:n)=b(ci,1,jtop(ci):jbot(ci)-2) ! 2nd superdiagonal - ab(kl+ku+0,2:n)=b(ci,2,jtop(ci):jbot(ci)-1) ! 1st superdiagonal - ab(kl+ku+1,1:n)=b(ci,3,jtop(ci):jbot(ci)) ! diagonal - ab(kl+ku+2,1:n-1)=b(ci,4,jtop(ci)+1:jbot(ci)) ! 1st subdiagonal - ab(kl+ku+3,1:n-2)=b(ci,5,jtop(ci)+2:jbot(ci)) ! 2nd subdiagonal - - allocate(temp(m,n)) - temp=ab + ! calculate the maximum N-dimension needed (jbot-jtop +1) + nmax = -100 + !$acc parallel loop gang vector default(present) reduction(max:nmax) copy(nmax) + do fc = 1, numf + ci = filter(fc) + n = jbot(ci)-jtop(ci)+1 + nmax = max(nmax,n) + end do - allocate(ipiv(n)) - allocate(result(n)) + ! m is the number of rows required for storage space by dgbsv + ! n is the number of levels (snow/soil) + !scs: replace ubj with jbot + + allocate(ab(1:m,1:nmax,1:numf), temp(1:m,1:nmax,1:numf), result(1:nmax,1:numf) ) + !$acc enter data create(ab(:,:,:) ,temp(:,:,:), result(:,:) ) + + ! initialize the matrices + !$acc parallel loop independent gang vector default(present) collapse(3) + do fc = 1, numf + do j = 1, nmax + do k = 1, m + ab(k,j,fc) = 0._r8 + temp(k,j,fc) = 0._r8 + end do + end do + end do -! on input result is rhs, on output result is solution vector - result(:)=r(ci,jtop(ci):jbot(ci)) + !$acc parallel loop independent gang vector default(present) + do fc = 1, numf + ci = filter(fc) + n = jbot(ci)-jtop(ci)+1 + result(1:n,fc) = r(ci, jtop(ci):jbot(ci)) + end do -! DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) - call dgbsv( n, kl, ku, 1, ab, m, ipiv, result, n, info ) - u(ci,jtop(ci):jbot(ci))=result(:) + !$acc parallel loop independent gang vector default(present) + do fc = 1, numf + ci = filter(fc) + n = jbot(ci)-jtop(ci)+1 + !band 1 : + !$acc loop seq + do j = 0, n-3 + ! ab(kl+ku-1,3:n)=b(ci,1,jtop(ci):jbot(ci)-2) ! 2nd superdiagonal + ab(kl+ku-1,3+j,fc) = b(ci,1,jtop(ci)+j) ! 2nd superdiagonal + end do + !$acc loop seq + do j = 0, n-2 + !ab(kl+ku+0,2:n,fc) = b(ci,2,jtop(ci):jbot(ci)-1) ! 1st superdiagonal + ab(kl+ku+0,2+j,fc) = b(ci,2,jtop(ci)+j) + end do + !$acc loop seq + do j = 0, n-1 + !ab(kl+ku+1,1:n,fc) = b(ci,3,jtop(ci):jbot(ci) ) ! diagonal + ab(kl+ku+1,1+j,fc) = b(ci,3,jtop(ci)+j) ! diagonal + end do + !$acc loop seq + do j = 0 , n-2 + !ab(kl+ku+2,1:n-1,fc) = b(ci,4,jtop(ci)+1:jbot(ci)) ! 1st subdiagonal + ab(kl+ku+2,1+j,fc) = b(ci,4,jtop(ci)+1+j ) ! 1st subdiagonal + end do + !$acc loop seq + do j = 0, n-3 + !ab(kl+ku+3,1:n-2,fc) = b(ci,5,jtop(ci)+2:jbot(ci)) ! 2nd subdiagonal + ab(kl+ku+3,1+j,fc) = b(ci,5,jtop(ci)+2+j) ! 2nd subdiagonal + end do + end do - if(info /= 0) then - write(iulog,*)'index: ', ci - write(iulog,*)'n,kl,ku,m ',n,kl,ku,m - write(iulog,*)'dgbsv info: ',ci,info - - write(iulog,*) '' - write(iulog,*) 'ab matrix' - do j=1,n - ! write(iulog,'(i2,7f18.7)') j,temp(:,j) - write(iulog,'(i2,5f18.7)') j,temp(3:7,j) - enddo - write(iulog,*) '' - stop - endif - deallocate(temp) + !$acc parallel loop independent gang vector default(present) collapse(3) + do fc = 1, numf + do j = 1, nmax + do k = 1, m + temp(k,j,fc) = ab(k,j,fc) + end do + end do + end do + + print *, "bd:" + !$acc parallel loop independent gang vector default(present) + do fc = 1,numf + ci = filter(fc) + n = jbot(ci)-jtop(ci)+1 + call dgbsv_oacc(n, kl, ku, 1, ab(1:m,1:n,fc), m , result(1:n,fc),n,info) + ! ! ! DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) + ! ! call dgbsv( n, kl, ku, 1, ab, m, ipiv, result, n, info ) - deallocate(ab) - deallocate(ipiv) - deallocate(result) end do + + !$acc parallel loop independent gang vector default(present) + do fc = 1, numf + ci = filter(fc) + n = jbot(ci)-jtop(ci)+1 + !$acc loop seq + do j =1, n + u(ci, jtop(ci)+j-1) = result(j,fc) + end do + end do + !$acc exit data delete(ab(:,:,:) ,temp(:,:,:), result(:,:) ) !!!!!!ipiv(:nmax,:numf) + deallocate(temp) + deallocate(ab) + deallocate(result) end subroutine BandDiagonal end module BandDiagonalMod diff --git a/components/elm/src/biogeophys/BareGroundFluxesMod.F90 b/components/elm/src/biogeophys/BareGroundFluxesMod.F90 index aff2447831b6..019cec846734 100644 --- a/components/elm/src/biogeophys/BareGroundFluxesMod.F90 +++ b/components/elm/src/biogeophys/BareGroundFluxesMod.F90 @@ -32,16 +32,14 @@ module BareGroundFluxesMod contains !------------------------------------------------------------------------------ - subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & - atm2lnd_vars, canopystate_vars, soilstate_vars, & + subroutine BareGroundFluxes( num_nolu_barep, filter_nolu_barep, & + canopystate_vars, soilstate_vars, & frictionvel_vars, ch4_vars) ! ! !DESCRIPTION: ! Compute sensible and latent fluxes and their derivatives with respect ! to ground temperature using ground temperatures from previous time step. - ! ! !USES: - !$acc routine seq use shr_const_mod , only : SHR_CONST_RGAS use shr_flux_mod , only : shr_flux_update_stress use elm_varpar , only : nlevgrnd @@ -55,10 +53,8 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & use elm_time_manager , only : get_nstep ! ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nolakeurbanp ! number of pft non-lake, non-urban points in pft filter - integer , intent(in) :: filter_nolakeurbanp(:) ! patch filter for non-lake, non-urban points - type(atm2lnd_type) , intent(in) :: atm2lnd_vars + integer , intent(in) :: num_nolu_barep ! number of pft non-lake, non-urban points in pft filter + integer , intent(in) :: filter_nolu_barep(:) ! patch filter for non-lake, non-urban bare pfts type(canopystate_type) , intent(in) :: canopystate_vars type(soilstate_type) , intent(in) :: soilstate_vars type(frictionvel_type) , intent(inout) :: frictionvel_vars @@ -68,57 +64,53 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & real(r8), parameter :: dtaumin = 0.01_r8 ! max limit for stress convergence [Pa] integer, parameter :: itmin = 3 ! minimum number of iterations integer, parameter :: itmax = 30 ! maximum number of iterations - integer :: p,c,t,g,f,j,l ! indices - integer :: filterp(bounds%endp-bounds%begp+1) ! patch filter for vegetated patches - integer :: fn ! number of values in local pft filter - integer :: filterp0(bounds%endp-bounds%begp+1) ! pre-iteration filterp - integer :: fn0 ! pre-iteration fn - integer :: fnold ! previous iteration fn - integer :: fp ! lake filter pft index + real(r8),PARAMETER :: beta = 1.0_r8 ! coefficient of convective velocity [-] + integer :: p,c,t,g,j,l ! indices + integer :: f ! filter pft index integer :: iter ! iteration index integer :: iter_final ! number of iterations used integer :: loopmax ! maximum number of iterations for this configuration - real(r8) :: zldis(bounds%begp:bounds%endp) ! reference height "minus" zero displacement height [m] - real(r8) :: displa(bounds%begp:bounds%endp) ! displacement height [m] - real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory - real(r8) :: beta ! coefficient of convective velocity [-] - real(r8) :: wc ! convective velocity [m/s] - real(r8) :: ugust_total(bounds%begp:bounds%endp) ! gustiness including convective velocity [m/s] - real(r8) :: dth(bounds%begp:bounds%endp) ! diff of virtual temp. between ref. height and surface - real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface - real(r8) :: dqh(bounds%begp:bounds%endp) ! diff of humidity between ref. height and surface - real(r8) :: obu(bounds%begp:bounds%endp) ! Obukhov length scale (m) - real(r8) :: ur(bounds%begp:bounds%endp) ! wind speed at reference height [m/s] - real(r8) :: um(bounds%begp:bounds%endp) ! wind speed including the stablity effect [m/s] - real(r8) :: temp1(bounds%begp:bounds%endp) ! relation for potential temperature profile - real(r8) :: temp12m(bounds%begp:bounds%endp) ! relation for potential temperature profile applied at 2-m - real(r8) :: temp2(bounds%begp:bounds%endp) ! relation for specific humidity profile - real(r8) :: temp22m(bounds%begp:bounds%endp) ! relation for specific humidity profile applied at 2-m - real(r8) :: ustar(bounds%begp:bounds%endp) ! friction velocity [m/s] - real(r8) :: tstar ! temperature scaling parameter - real(r8) :: qstar ! moisture scaling parameter - real(r8) :: thvstar ! virtual potential temperature scaling parameter - real(r8) :: cf ! heat transfer coefficient from leaves [-] - real(r8) :: ram ! aerodynamical resistance [s/m] - real(r8) :: rah ! thermal resistance [s/m] - real(r8) :: raw ! moisture resistance [s/m] - real(r8) :: raih ! temporary variable [kg/m2/s] - real(r8) :: raiw ! temporary variable [kg/m2/s] - real(r8) :: fm(bounds%begp:bounds%endp) ! needed for BGC only to diagnose 10m wind speed - real(r8) :: z0mg_patch(bounds%begp:bounds%endp) - real(r8) :: z0hg_patch(bounds%begp:bounds%endp) - real(r8) :: z0qg_patch(bounds%begp:bounds%endp) + real(r8) :: zldis ! reference height "minus" zero displacement height [m] + real(r8) :: displa ! displacement height [m] + real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: dth ! diff of virtual temp. between ref. height and surface + real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: dqh ! diff of humidity between ref. height and surface + real(r8) :: obu ! Monin-Obukhov length (m) + real(r8) :: ur ! wind speed at reference height [m/s] + real(r8) :: um ! wind speed including the stablity effect [m/s] + real(r8) :: temp1 ! relation for potential temperature profile + real(r8) :: temp12m ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2 ! relation for specific humidity profile + real(r8) :: temp22m ! relation for specific humidity profile applied at 2-m + real(r8) :: ustar ! friction velocity [m/s] + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: cf ! heat transfer coefficient from leaves [-] + real(r8) :: ram ! aerodynamical resistance [s/m] + real(r8) :: rah ! thermal resistance [s/m] + real(r8) :: raw ! moisture resistance [s/m] + real(r8) :: raih ! temporary variable [kg/m2/s] + real(r8) :: raiw ! temporary variable [kg/m2/s] + real(r8) :: fm ! needed for BGC only to diagnose 10m wind speed + real(r8) :: z0mg_patch + real(r8) :: z0hg_patch + real(r8) :: z0qg_patch real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m real(r8) :: www ! surface soil wetness [-] - real(r8) :: wind_speed0(bounds%begp:bounds%endp) ! Wind speed from atmosphere at start of iteration - real(r8) :: wind_speed_adj(bounds%begp:bounds%endp) ! Adjusted wind speed for iteration - real(r8) :: tau(bounds%begp:bounds%endp) ! Stress used in iteration - real(r8) :: tau_diff(bounds%begp:bounds%endp) ! Difference from previous iteration tau - real(r8) :: prev_tau(bounds%begp:bounds%endp) ! Previous iteration tau - real(r8) :: prev_tau_diff(bounds%begp:bounds%endp) ! Previous difference in iteration tau + real(r8) :: ugust_total ! gustiness including convective velocity [m/s] + real(r8) :: wind_speed0 ! Wind speed from atmosphere at start of iteration + real(r8) :: wind_speed_adj ! Adjusted wind speed for iteration + real(r8) :: tau ! Stress used in iteration + real(r8) :: tau_diff ! Difference from previous iteration tau + real(r8) :: prev_tau ! Previous iteration tau + real(r8) :: prev_tau_diff ! Previous difference in iteration tau + logical :: unconverged !------------------------------------------------------------------------------ associate( & @@ -135,7 +127,15 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & forc_rho => top_as%rhobot , & ! Input: [real(r8) (:) ] density (kg/m**3) forc_q => top_as%qbot , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) - forc_hgt_u_patch => frictionvel_vars%forc_hgt_u_patch , & ! Input: + forc_hgt_u_patch => frictionvel_vars%forc_hgt_u_patch , & ! Input: + forc_hgt_t_patch => frictionvel_vars%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] + forc_hgt_q_patch => frictionvel_vars%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] + vds => frictionvel_vars%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) + u10 => frictionvel_vars%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) + u10_elm => frictionvel_vars%u10_elm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) + u10_with_gusts_elm=>frictionvel_vars%u10_with_gusts_elm_patch, & ! Output: [real(r8) (:) ] 10-m wind with gusts(m/s) + va => frictionvel_vars%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) + fv => frictionvel_vars%fv_patch , & ! Output: [real(r8) (:) ] friction velocity (m/s) (for dust model) frac_veg_nosno => canopystate_vars%frac_veg_nosno_patch , & ! Input: [logical (:) ] true=> pft is bare ground (elai+esai = zero) @@ -144,22 +144,22 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & watsat => soilstate_vars%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) soilbeta => soilstate_vars%soilbeta_col , & ! Input: [real(r8) (:) ] soil wetness relative to field capacity - t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) - t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground surface temperature [K] - thv => col_es%thv , & ! Input: [real(r8) (:) ] virtual potential temperature (kelvin) - thm => veg_es%thm , & ! Input: [real(r8) (:) ] intermediate variable (forc_t+0.0098*forc_hgt_t_patch) - t_h2osfc => col_es%t_h2osfc , & ! Input: [real(r8) (:) ] surface water temperature + t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground surface temperature [K] + thv => col_es%thv , & ! Input: [real(r8) (:) ] virtual potential temperature (kelvin) + thm => veg_es%thm , & ! Input: [real(r8) (:) ] intermediate variable (forc_t+0.0098*forc_hgt_t_patch) + t_h2osfc => col_es%t_h2osfc , & ! Input: [real(r8) (:) ] surface water temperature - frac_sno => col_ws%frac_sno , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) - qg_snow => col_ws%qg_snow , & ! Input: [real(r8) (:) ] specific humidity at snow surface [kg/kg] - qg_soil => col_ws%qg_soil , & ! Input: [real(r8) (:) ] specific humidity at soil surface [kg/kg] - qg_h2osfc => col_ws%qg_h2osfc , & ! Input: [real(r8) (:) ] specific humidity at h2osfc surface [kg/kg] - qg => col_ws%qg , & ! Input: [real(r8) (:) ] specific humidity at ground surface [kg/kg] - dqgdT => col_ws%dqgdT , & ! Input: [real(r8) (:) ] temperature derivative of "qg" - h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) - h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) + frac_sno => col_ws%frac_sno , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) + qg_snow => col_ws%qg_snow , & ! Input: [real(r8) (:) ] specific humidity at snow surface [kg/kg] + qg_soil => col_ws%qg_soil , & ! Input: [real(r8) (:) ] specific humidity at soil surface [kg/kg] + qg_h2osfc => col_ws%qg_h2osfc , & ! Input: [real(r8) (:) ] specific humidity at h2osfc surface [kg/kg] + qg => col_ws%qg , & ! Input: [real(r8) (:) ] specific humidity at ground surface [kg/kg] + dqgdT => col_ws%dqgdT , & ! Input: [real(r8) (:) ] temperature derivative of "qg" + h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) + h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) - grnd_ch4_cond => ch4_vars%grnd_ch4_cond_patch , & ! Output: [real(r8) (:) ] tracer conductance for boundary layer [m/s] + grnd_ch4_cond => ch4_vars%grnd_ch4_cond_patch , & ! Output: [real(r8) (:) ] tracer conductance for boundary layer [m/s] eflx_sh_snow => veg_ef%eflx_sh_snow , & ! Output: [real(r8) (:) ] sensible heat flux from snow (W/m**2) [+ to atm] eflx_sh_soil => veg_ef%eflx_sh_soil , & ! Output: [real(r8) (:) ] sensible heat flux from soil (W/m**2) [+ to atm] @@ -177,14 +177,14 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & t_ref2m => veg_es%t_ref2m , & ! Output: [real(r8) (:) ] 2 m height surface air temperature (Kelvin) t_ref2m_r => veg_es%t_ref2m_r , & ! Output: [real(r8) (:) ] Rural 2 m height surface air temperature (Kelvin) - q_ref2m => veg_ws%q_ref2m , & ! Output: [real(r8) (:) ] 2 m height surface specific humidity (kg/kg) - rh_ref2m_r => veg_ws%rh_ref2m_r , & ! Output: [real(r8) (:) ] Rural 2 m height surface relative humidity (%) - rh_ref2m => veg_ws%rh_ref2m , & ! Output: [real(r8) (:) ] 2 m height surface relative humidity (%) + q_ref2m => veg_ws%q_ref2m , & ! Output: [real(r8) (:) ] 2 m height surface specific humidity (kg/kg) + rh_ref2m_r => veg_ws%rh_ref2m_r , & ! Output: [real(r8) (:) ] Rural 2 m height surface relative humidity (%) + rh_ref2m => veg_ws%rh_ref2m , & ! Output: [real(r8) (:) ] 2 m height surface relative humidity (%) - z0mg_col => frictionvel_vars%z0mg_col , & ! Output: [real(r8) (:) ] roughness length, momentum [m] - z0hg_col => frictionvel_vars%z0hg_col , & ! Output: [real(r8) (:) ] roughness length, sensible heat [m] - z0qg_col => frictionvel_vars%z0qg_col , & ! Output: [real(r8) (:) ] roughness length, latent heat [m] - ram1 => frictionvel_vars%ram1_patch , & ! Output: [real(r8) (:) ] aerodynamical resistance (s/m) + z0mg_col => frictionvel_vars%z0mg_col , & ! Output: [real(r8) (:) ] roughness length, momentum [m] + z0hg_col => frictionvel_vars%z0hg_col , & ! Output: [real(r8) (:) ] roughness length, sensible heat [m] + z0qg_col => frictionvel_vars%z0qg_col , & ! Output: [real(r8) (:) ] roughness length, latent heat [m] + ram1 => frictionvel_vars%ram1_patch , & ! Output: [real(r8) (:) ] aerodynamical resistance (s/m) qflx_ev_snow => veg_wf%qflx_ev_snow , & ! Output: [real(r8) (:) ] evaporation flux from snow (W/m**2) [+ to atm] qflx_ev_soil => veg_wf%qflx_ev_soil , & ! Output: [real(r8) (:) ] evaporation flux from soil (W/m**2) [+ to atm] @@ -199,69 +199,53 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & !--------------------------------------------------- ! Filter patches where frac_veg_nosno IS ZERO !--------------------------------------------------- - - beta = 1._r8 ! previously set as a constant for all columns in CanopyTemperature() - - fn = 0 - do fp = 1,num_nolakeurbanp - p = filter_nolakeurbanp(fp) - if (frac_veg_nosno(p) == 0) then - fn = fn + 1 - filterp(fn) = p - end if - end do ! Compute sensible and latent fluxes and their derivatives with respect ! to ground temperature using ground temperatures from previous time step - - do f = 1, fn - p = filterp(f) + !$acc parallel loop independent gang vector default(present) + do f = 1, num_nolu_barep + p = filter_nolu_barep(f) c = veg_pp%column(p) t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) + l = veg_pp%landunit(p) + + iter = 0 ! Initialization variables - displa(p) = 0._r8 + displa = 0._r8 dlrad(p) = 0._r8 ulrad(p) = 0._r8 ! Initialize winds for iteration. if (implicit_stress) then - wind_speed0(p) = max(0.01_r8, hypot(forc_u(t), forc_v(t))) - wind_speed_adj(p) = wind_speed0(p) - ur(p) = max(1.0_r8, sqrt(wind_speed_adj(p)**2 + ugust(t)**2)) + wind_speed0 = max(0.01_r8, hypot(forc_u(t), forc_v(t))) + wind_speed_adj = wind_speed0 + ur = max(1.0_r8, sqrt(wind_speed_adj**2 + ugust(t)**2)) - prev_tau(p) = tau_est(t) + prev_tau = tau_est(t) else - ur(p) = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t)+ugust(t)*ugust(t))) + ur = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t)+ugust(t)*ugust(t))) end if - tau_diff(p) = 1.e100_r8 - ugust_total(p) = ugust(t) + tau_diff = 1.e100_r8 + ugust_total = ugust(t) - dth(p) = thm(p)-t_grnd(c) - dqh(p) = forc_q(t) - qg(c) - dthv = dth(p)*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh(p) - zldis(p) = forc_hgt_u_patch(p) + ur = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t))) + dth = thm(p)-t_grnd(c) + dqh = forc_q(t) - qg(c) + dthv = dth*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh + zldis = forc_hgt_u_patch(p) ! Copy column roughness to local pft-level arrays - z0mg_patch(p) = z0mg_col(c) - z0hg_patch(p) = z0hg_col(c) - z0qg_patch(p) = z0qg_col(c) + z0mg_patch = z0mg_col(c) + z0hg_patch = z0hg_col(c) + z0qg_patch = z0qg_col(c) ! Initialize Obukhov length scale and wind speed - call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg_patch(p), um(p), obu(p)) - num_iter(p) = 0._r8 - end do - - ! Perform stability iteration - ! Determine friction velocity, and potential temperature and humidity - ! profiles of the surface boundary layer - - fn0 = fn - filterp0(1:fn) = filterp(1:fn) + call MoninObukIni(ur, thv(c), dthv, zldis, z0mg_patch, um, obu) + num_iter(p) = 0._8 if (implicit_stress) then loopmax = itmax @@ -269,88 +253,64 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & loopmax = itmin end if - ITERATION: do iter = 1, loopmax + unconverged = .true. + iter = 1 + do while( iter <= loopmax .and. unconverged) - call FrictionVelocity(begp, endp, fn, filterp, & - displa(begp:endp), z0mg_patch(begp:endp), z0hg_patch(begp:endp), z0qg_patch(begp:endp), & - obu(begp:endp), iter, ur(begp:endp), um(begp:endp), ugust_total(begp:endp), ustar(begp:endp), & - temp1(begp:endp), temp2(begp:endp), temp12m(begp:endp), temp22m(begp:endp), fm(begp:endp), & - frictionvel_vars) - - do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) + call FrictionVelocity_noloop( & + displa, z0mg_patch, z0hg_patch, z0qg_patch, & + obu, iter, ur, um, ugust_total ,ustar, & + temp1, temp2, temp12m, temp22m, fm, & + forc_hgt_u_patch(p), forc_hgt_t_patch(p), forc_hgt_q_patch(p), & + vds(p), u10(p), u10_elm(p), u10_with_gusts_elm(p) ,va(p), fv(p)) ! Calculate magnitude of stress and update wind speed. if (implicit_stress) then - ram = 1._r8/(ustar(p)*ustar(p)/um(p)) - tau(p) = forc_rho(t)*wind_speed_adj(p)/ram - call shr_flux_update_stress(wind_speed0(p), wsresp(t), tau_est(t), & - tau(p), prev_tau(p), tau_diff(p), prev_tau_diff(p), & - wind_speed_adj(p)) - ur(p) = max(1.0_r8, sqrt(wind_speed_adj(p)**2 + ugust(t)**2)) + ram = 1._r8/(ustar*ustar/um) + tau = forc_rho(t)*wind_speed_adj/ram + call shr_flux_update_stress(wind_speed0, wsresp(t), tau_est(t), & + tau, prev_tau, tau_diff, prev_tau_diff, & + wind_speed_adj) + ur = max(1.0_r8, sqrt(wind_speed_adj**2 + ugust(t)**2)) end if - tstar = temp1(p)*dth(p) - qstar = temp2(p)*dqh(p) - z0hg_patch(p) = z0mg_patch(p)/exp(0.13_r8 * (ustar(p)*z0mg_patch(p)/1.5e-5_r8)**0.45_r8) - z0qg_patch(p) = z0hg_patch(p) + tstar = temp1*dth + qstar = temp2*dqh + z0hg_patch = z0mg_patch/exp(0.13_r8 * (ustar*z0mg_patch/1.5e-5_r8)**0.45_r8) + z0qg_patch = z0hg_patch thvstar = tstar*(1._r8+0.61_r8*forc_q(t)) + 0.61_r8*forc_th(t)*qstar - zeta = zldis(p)*vkc*grav*thvstar/(ustar(p)**2*thv(c)) + zeta = zldis*vkc*grav*thvstar/(ustar**2*thv(c)) if (zeta >= 0._r8) then !stable zeta = min(2._r8,max(zeta,0.01_r8)) - um(p) = max(ur(p),0.1_r8) + um = max(ur,0.1_r8) else !unstable zeta = max(-100._r8,min(zeta,-0.01_r8)) if ((.not. atm_gustiness) .or. force_land_gustiness) then - wc = beta*(-grav*ustar(p)*thvstar*zii(c)/thv(c))**0.333_r8 - ugust_total(p) = sqrt(ugust(t)**2 + wc**2) - um(p) = sqrt(ur(p)*ur(p) + wc*wc) + wc = beta*(-grav*ustar*thvstar*zii(c)/thv(c))**0.333_r8 + ugust_total = sqrt(ugust(t)**2 + wc**2) + um = sqrt(ur*ur + wc*wc) else - um(p) = max(ur(p),0.1_r8) + um = max(ur,0.1_r8) end if end if - obu(p) = zldis(p)/zeta - end do + obu = zldis/zeta ! Test for convergence - iter_final = iter if (iter >= itmin) then - fnold = fn - fn = 0 - do f = 1, fnold - p = filterp(f) - num_iter(p) = real(iter,r8) - if (.not. (abs(tau_diff(p)) < dtaumin)) then - fn = fn + 1 - filterp(fn) = p - end if - end do - if (fn == 0) then - exit ITERATION + num_iter(p) = real(iter,r8) + if ( (abs(tau_diff) < dtaumin)) then + unconverged = .false. end if end if - + iter = iter + 1 end do ITERATION ! end stability iteration - fn = fn0 - filterp(1:fn) = filterp0(1:fn) - - do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) - g = veg_pp%gridcell(p) - t = veg_pp%topounit(p) - l = veg_pp%landunit(p) - ! Determine aerodynamic resistances - ram = 1._r8/(ustar(p)*ustar(p)/um(p)) - rah = 1._r8/(temp1(p)*ustar(p)) - raw = 1._r8/(temp2(p)*ustar(p)) + ram = 1._r8/(ustar*ustar/um) + rah = 1._r8/(temp1*ustar) + raw = 1._r8/(temp2*ustar) raih = forc_rho(t)*cpair/rah if (use_lch4) then grnd_ch4_cond(p) = 1._r8/raw @@ -361,7 +321,7 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & www = min(max(www,0.0_r8),1._r8) !changed by K.Sakaguchi. Soilbeta is used for evaporation - if (dqh(p) > 0._r8) then !dew (beta is not applied, just like rsoil used to be) + if (dqh > 0._r8) then !dew (beta is not applied, just like rsoil used to be) raiw = forc_rho(t)/(raw) else if(do_soilevap_beta())then @@ -383,10 +343,10 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & taux(p) = -forc_rho(t)*forc_u(t)/ram tauy(p) = -forc_rho(t)*forc_v(t)/ram if (implicit_stress) then - taux(p) = taux(p) * (wind_speed_adj(p) / wind_speed0(p)) - tauy(p) = tauy(p) * (wind_speed_adj(p) / wind_speed0(p)) + taux(p) = taux(p) * (wind_speed_adj / wind_speed0) + tauy(p) = tauy(p) * (wind_speed_adj / wind_speed0) end if - eflx_sh_grnd(p) = -raih*dth(p) + eflx_sh_grnd(p) = -raih*dth eflx_sh_tot(p) = eflx_sh_grnd(p) ! compute sensible heat fluxes individually @@ -395,7 +355,7 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & eflx_sh_h2osfc(p) = -raih*(thm(p)-t_h2osfc(c)) ! water fluxes from soil - qflx_evap_soi(p) = -raiw*dqh(p) + qflx_evap_soi(p) = -raiw*dqh qflx_evap_tot(p) = qflx_evap_soi(p) ! compute latent heat fluxes individually @@ -404,10 +364,10 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & qflx_ev_h2osfc(p) = -raiw*(forc_q(t) - qg_h2osfc(c)) ! 2 m height air temperature - t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p)) + t_ref2m(p) = thm(p) + temp1*dth*(1._r8/temp12m - 1._r8/temp1) ! 2 m height specific humidity - q_ref2m(p) = forc_q(t) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p)) + q_ref2m(p) = forc_q(t) + temp2*dqh*(1._r8/temp22m - 1._r8/temp2) ! 2 m height relative humidity call QSat(t_ref2m(p), forc_pbot(t), e_ref2m, de2mdT, qsat_ref2m, dqsat2mdT) @@ -420,12 +380,12 @@ subroutine BareGroundFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & end if ! Check for convergence of stress. - if (implicit_stress .and. abs(tau_diff(p)) > dtaumin) then + if (implicit_stress .and. abs(tau_diff) > dtaumin) then if (get_nstep() > 0) then ! Suppress common warnings on the first time step. write(iulog,*)'WARNING: Stress did not converge for bare ground ',& - ' nstep = ',get_nstep(),' p= ',p,' prev_tau_diff= ',prev_tau_diff(p),& - ' tau_diff= ',tau_diff(p),' tau= ',tau(p),& - ' wind_speed_adj= ',wind_speed_adj(p),' iter_final= ',iter_final + ' nstep = ',get_nstep(),' p= ',p,' prev_tau_diff= ',prev_tau_diff,& + ' tau_diff= ',tau_diff,' tau= ',tau,& + ' wind_speed_adj= ',wind_speed_adj,' iter_final= ',iter_final end if end if diff --git a/components/elm/src/biogeophys/CanopyFluxesMod.F90 b/components/elm/src/biogeophys/CanopyFluxesMod.F90 index d29d89323023..b6ed79cc471c 100644 --- a/components/elm/src/biogeophys/CanopyFluxesMod.F90 +++ b/components/elm/src/biogeophys/CanopyFluxesMod.F90 @@ -1,7 +1,7 @@ module CanopyFluxesMod #include "shr_assert.h" - + !------------------------------------------------------------------------------ ! !DESCRIPTION: ! Performs calculation of leaf temperature and surface fluxes. @@ -42,10 +42,8 @@ module CanopyFluxesMod use ColumnDataType , only : col_es, col_ef, col_ws use VegetationType , only : veg_pp use VegetationDataType , only : veg_es, veg_ef, veg_ws, veg_wf - - !!! using elm_instMod messes with the compilation order + ! using elm_instMod messes with the compilation order use elm_instMod , only : alm_fates, soil_water_retention_curve - use TemperatureType , only : temperature_vars use perf_mod, only: t_startf, t_stopf use timeinfoMod use spmdmod , only: masterproc @@ -60,10 +58,12 @@ module CanopyFluxesMod contains !------------------------------------------------------------------------------ - subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & - atm2lnd_vars, canopystate_vars, cnstate_vars, energyflux_vars, & + subroutine CanopyFluxes(bounds, num_nolu_barep, filter_nolu_barep, & + num_nolu_vegp, filter_nolu_vegp , & + canopystate_vars, cnstate_vars, energyflux_vars, & frictionvel_vars, soilstate_vars, solarabs_vars, surfalb_vars, & ch4_vars, photosyns_vars) + ! !DESCRIPTION: ! 1. Calculates the leaf temperature: ! 2. Calculates the leaf fluxes, transpiration, photosynthesis and @@ -92,7 +92,6 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! less than 0.1 W/m2; or the iterative steps over 40. ! ! !USES: - !$acc routine seq use shr_const_mod , only : SHR_CONST_TKFRZ, SHR_CONST_RGAS use shr_flux_mod , only : shr_flux_update_stress use elm_varcon , only : sb, cpair, hvap, vkc, grav, denice @@ -101,12 +100,10 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & use pftvarcon , only : irrigated use elm_varcon , only : c14ratio use shr_const_mod , only : SHR_CONST_PI - - !NEW use elm_varsur , only : firrig use TopounitType , only : top_pp use QSatMod , only : QSat - use FrictionVelocityMod, only : FrictionVelocity, MoninObukIni, & + use FrictionVelocityMod, only : FrictionVelocity_noloop, MoninObukIni, & implicit_stress, atm_gustiness, force_land_gustiness use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type use SurfaceResistanceMod, only : getlblcef @@ -114,11 +111,12 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nolakeurbanp ! number of column non-lake, non-urban points in pft filter - integer , intent(in) :: filter_nolakeurbanp(:) ! patch filter for non-lake, non-urban points - type(atm2lnd_type) , intent(inout) :: atm2lnd_vars + integer , intent(in) :: num_nolu_barep + integer , intent(in) :: filter_nolu_barep(:) + integer , intent(in) :: num_nolu_vegp + integer , intent(in) :: filter_nolu_vegp(:) type(canopystate_type) , intent(inout) :: canopystate_vars - type(cnstate_type) , intent(inout) :: cnstate_vars + type(cnstate_type) , intent(inout) :: cnstate_vars type(energyflux_type) , intent(inout) :: energyflux_vars type(frictionvel_type) , intent(inout) :: frictionvel_vars type(solarabs_type) , intent(inout) :: solarabs_vars @@ -126,7 +124,6 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & type(soilstate_type) , intent(inout) :: soilstate_vars type(ch4_type) , intent(inout) :: ch4_vars type(photosyns_type) , intent(inout) :: photosyns_vars - real(r8) :: dtime integer :: time ! ! !LOCAL VARIABLES: @@ -134,13 +131,12 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & real(r8), pointer :: bsha(:) ! shaded canopy transpiration wetness factor (0 to 1) real(r8), parameter :: btran0 = 0.0_r8 ! initial value real(r8), parameter :: zii = 1000.0_r8 ! convective boundary layer height [m] - real(r8), parameter :: beta = 1.0_r8 ! coefficient of convective velocity [-] + real(r8), parameter :: beta = 1.0_r8 ! coefficient of conective velocity [-] real(r8), parameter :: delmax = 1.0_r8 ! maxchange in leaf temperature [K] real(r8), parameter :: dlemin = 0.1_r8 ! max limit for energy flux convergence [w/m2] real(r8), parameter :: dtmin = 0.01_r8 ! max limit for temperature convergence [K] - real(r8), parameter :: dtaumin = 0.01_r8! max limit for stress convergence [Pa] - integer , parameter :: itmax = 41 ! maximum number of iteration [-] - integer , parameter :: itmin = 3 ! minimum number of iteration [-] + integer , parameter :: itmax = 40 ! maximum number of iteration [-] + integer , parameter :: itmin = 2 ! minimum number of iteration [-] real(r8), parameter :: irrig_min_lai = 0.0_r8 ! Minimum LAI for irrigation real(r8), parameter :: irrig_btran_thresh = 0.999999_r8 ! Irrigate when btran falls below 0.999999 rather than 1 to allow for round-off error integer , parameter :: irrig_start_time = isecspday/4 ! (6AM) Time of day to check whether we need irrigation, seconds (0 = midnight). @@ -170,121 +166,119 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & !added by K.Sakaguchi for stability formulation real(r8), parameter :: ria = 0.5_r8 ! free parameter for stable formulation (currently = 0.5, "gamma" in Sakaguchi&Zeng,2008) - real(r8) :: zldis(bounds%begp:bounds%endp) ! reference height "minus" zero displacement height [m] - real(r8) :: wc ! convective velocity [m/s] - real(r8) :: ugust_total(bounds%begp:bounds%endp) ! gustiness including convective velocity [m/s] - real(r8) :: dth(bounds%begp:bounds%endp) ! diff of virtual temp. between ref. height and surface - real(r8) :: dthv(bounds%begp:bounds%endp) ! diff of vir. poten. temp. between ref. height and surface - real(r8) :: dqh(bounds%begp:bounds%endp) ! diff of humidity between ref. height and surface - real(r8) :: ur(bounds%begp:bounds%endp) ! wind speed at reference height [m/s] - real(r8) :: temp1(bounds%begp:bounds%endp) ! relation for potential temperature profile - real(r8) :: temp12m(bounds%begp:bounds%endp) ! relation for potential temperature profile applied at 2-m - real(r8) :: temp2(bounds%begp:bounds%endp) ! relation for specific humidity profile - real(r8) :: temp22m(bounds%begp:bounds%endp) ! relation for specific humidity profile applied at 2-m - real(r8) :: tstar ! temperature scaling parameter - real(r8) :: qstar ! moisture scaling parameter - real(r8) :: thvstar ! virtual potential temperature scaling parameter - real(r8) :: taf(bounds%begp:bounds%endp) ! air temperature within canopy space [K] - real(r8) :: qaf(bounds%begp:bounds%endp) ! humidity of canopy air [kg/kg] - real(r8) :: rpp ! fraction of potential evaporation from leaf [-] - real(r8) :: rppdry ! fraction of potential evaporation through transp [-] - real(r8) :: cf ! heat transfer coefficient from leaves [-] - real(r8) :: cf_bare ! heat transfer coefficient from bare ground [-] - real(r8) :: rb(bounds%begp:bounds%endp) ! leaf boundary layer resistance [s/m] - real(r8) :: rah(bounds%begp:bounds%endp,2) ! thermal resistance [s/m] - real(r8) :: raw(bounds%begp:bounds%endp,2) ! moisture resistance [s/m] - real(r8) :: wta ! heat conductance for air [m/s] - real(r8) :: wtg(bounds%begp:bounds%endp) ! heat conductance for ground [m/s] - real(r8) :: wtl ! heat conductance for leaf [m/s] - real(r8) :: wta0(bounds%begp:bounds%endp) ! normalized heat conductance for air [-] - real(r8) :: wtl0(bounds%begp:bounds%endp) ! normalized heat conductance for leaf [-] - real(r8) :: wtg0 ! normalized heat conductance for ground [-] - real(r8) :: wtal(bounds%begp:bounds%endp) ! normalized heat conductance for air and leaf [-] - real(r8) :: wtga ! normalized heat cond. for air and ground [-] - real(r8) :: wtaq ! latent heat conductance for air [m/s] - real(r8) :: wtlq ! latent heat conductance for leaf [m/s] - real(r8) :: wtgq(bounds%begp:bounds%endp) ! latent heat conductance for ground [m/s] - real(r8) :: wtaq0(bounds%begp:bounds%endp) ! normalized latent heat conductance for air [-] - real(r8) :: wtlq0(bounds%begp:bounds%endp) ! normalized latent heat conductance for leaf [-] - real(r8) :: wtgq0 ! normalized heat conductance for ground [-] - real(r8) :: wtalq(bounds%begp:bounds%endp) ! normalized latent heat cond. for air and leaf [-] - real(r8) :: wtgaq ! normalized latent heat cond. for air and ground [-] - real(r8) :: el(bounds%begp:bounds%endp) ! vapor pressure on leaf surface [pa] - real(r8) :: deldT ! derivative of "el" on "t_veg" [pa/K] - real(r8) :: qsatl(bounds%begp:bounds%endp) ! leaf specific humidity [kg/kg] - real(r8) :: qsatldT(bounds%begp:bounds%endp) ! derivative of "qsatl" on "t_veg" - real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] - real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m - real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] - real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m - real(r8) :: air(bounds%begp:bounds%endp) ! atmos. radiation temporay set - real(r8) :: bir(bounds%begp:bounds%endp) ! atmos. radiation temporay set - real(r8) :: cir(bounds%begp:bounds%endp) ! atmos. radiation temporay set - real(r8) :: dc1,dc2 ! derivative of energy flux [W/m2/K] - real(r8) :: delt ! temporary - real(r8) :: delq(bounds%begp:bounds%endp) ! temporary - real(r8) :: del(bounds%begp:bounds%endp) ! absolute change in leaf temp in current iteration [K] - real(r8) :: del2(bounds%begp:bounds%endp) ! change in leaf temperature in previous iteration [K] - real(r8) :: dele(bounds%begp:bounds%endp) ! change in latent heat flux from leaf [K] - real(r8) :: dels ! change in leaf temperature in current iteration [K] - real(r8) :: det(bounds%begp:bounds%endp) ! maximum leaf temp. change in two consecutive iter [K] - real(r8) :: efeb(bounds%begp:bounds%endp) ! latent heat flux from leaf (previous iter) [mm/s] - real(r8) :: efeold ! latent heat flux from leaf (previous iter) [mm/s] - real(r8) :: efpot ! potential latent energy flux [kg/m2/s] - real(r8) :: efe(bounds%begp:bounds%endp) ! water flux from leaf [mm/s] - real(r8) :: efsh ! sensible heat from leaf [mm/s] - real(r8) :: obuold(bounds%begp:bounds%endp) ! Obukhov length scale from previous iteration - real(r8) :: tlbef(bounds%begp:bounds%endp) ! leaf temperature from previous iteration [K] - real(r8) :: ecidif ! excess energies [W/m2] - real(r8) :: err(bounds%begp:bounds%endp) ! balance error - real(r8) :: erre ! balance error - real(r8) :: co2(bounds%begp:bounds%endp) ! atmospheric co2 partial pressure (pa) - real(r8) :: c13o2(bounds%begp:bounds%endp) ! atmospheric c13o2 partial pressure (pa) - real(r8) :: o2(bounds%begp:bounds%endp) ! atmospheric o2 partial pressure (pa) - real(r8) :: svpts(bounds%begp:bounds%endp) ! saturation vapor pressure at t_veg (pa) - real(r8) :: eah(bounds%begp:bounds%endp) ! canopy air vapor pressure (pa) - real(r8) :: s_node ! vol_liq/eff_porosity - real(r8) :: smp_node ! matrix potential - real(r8) :: smp_node_lf ! F. Li and S. Levis - real(r8) :: vol_liq ! partial volume of liquid water in layer - integer :: itlef ! counter for leaf temperature iteration [-] - integer :: iter_final ! number of iterations used - integer :: nmozsgn(bounds%begp:bounds%endp) ! number of times stability changes sign - real(r8) :: w ! exp(-LSAI) - real(r8) :: csoilcn ! interpolated csoilc for less than dense canopies - real(r8) :: fm(bounds%begp:bounds%endp) ! needed for BGC only to diagnose 10m wind speed - real(r8) :: wtshi ! sensible heat resistance for air, grnd and leaf [-] - real(r8) :: wtsqi ! latent heat resistance for air, grnd and leaf [-] - integer :: j ! soil/snow level index - integer :: p ! patch index - integer :: c ! column index - integer :: l ! landunit index - integer :: t ! topounit index - integer :: tpu_ind ! index of topounit to grid - integer :: g ! gridcell index - integer :: fp ! lake filter pft index - integer :: fn_noveg ! number of values in bare ground pft filter - integer :: filterp_noveg(bounds%endp-bounds%begp+1) ! bare ground pft filter - integer :: fn ! number of values in vegetated pft filter - integer :: filterp(bounds%endp-bounds%begp+1) ! vegetated pft filter - integer :: fnorig ! number of values in pft filter copy - integer :: fporig(bounds%endp-bounds%begp+1) ! temporary filter - integer :: fnold ! temporary copy of pft count - integer :: f ! filter index - logical :: found ! error flag for canopy above forcing hgt - integer :: index ! patch index for error - real(r8) :: egvf ! effective green vegetation fraction - real(r8) :: lt ! elai+esai - real(r8) :: ri ! stability parameter for under canopy air (unitless) - real(r8) :: csoilb ! turbulent transfer coefficient over bare soil (unitless) - real(r8) :: ricsoilc ! modified transfer coefficient under dense canopy (unitless) - real(r8) :: snow_depth_c ! critical snow depth to cover plant litter (m) - real(r8) :: rdl ! dry litter layer resistance for water vapor (s/m) - real(r8) :: elai_dl ! exposed (dry) plant litter area index - real(r8) :: fsno_dl ! effective snow cover over plant litter - real(r8) :: dayl_factor(bounds%begp:bounds%endp) ! scalar (0-1) for daylength effect on Vcmax + real(r8) :: zldis(num_nolu_vegp) ! reference height "minus" zero displacement height [m] + ! real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory + real(r8) :: wc ! convective velocity [m/s] + real(r8) :: dth(num_nolu_vegp) ! diff of virtual temp. between ref. height and surface + real(r8) :: dthv(num_nolu_vegp) ! diff of vir. poten. temp. between ref. height and surface + real(r8) :: dqh(num_nolu_vegp) ! diff of humidity between ref. height and surface + real(r8) :: obu(num_nolu_vegp) ! Monin-Obukhov length (m) + real(r8) :: um (num_nolu_vegp) ! wind speed including the stablity effect [m/s] + real(r8) :: ur (num_nolu_vegp) ! wind speed at reference height [m/s] + real(r8) :: uaf(num_nolu_vegp) ! velocity of air within foliage [m/s] + real(r8) :: temp1(num_nolu_vegp) ! relation for potential temperature profile + real(r8) :: temp12m(num_nolu_vegp) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2 (num_nolu_vegp) ! relation for specific humidity profile + real(r8) :: temp22m(num_nolu_vegp) ! relation for specific humidity profile applied at 2-m + real(r8) :: ustar (num_nolu_vegp) ! friction velocity [m/s] + real(r8) :: tstar ! temperature scaling parameter + real(r8) :: qstar ! moisture scaling parameter + real(r8) :: thvstar ! virtual potential temperature scaling parameter + real(r8) :: taf(num_nolu_vegp) ! air temperature within canopy space [K] + real(r8) :: qaf(num_nolu_vegp) ! humidity of canopy air [kg/kg] + real(r8) :: rpp ! fraction of potential evaporation from leaf [-] + real(r8) :: rppdry ! fraction of potential evaporation through transp [-] + real(r8) :: cf ! heat transfer coefficient from leaves [-] + real(r8) :: cf_bare ! heat transfer coefficient from bare ground [-] + real(r8) :: rb(num_nolu_vegp) ! leaf boundary layer resistance [s/m] + real(r8) :: rah(num_nolu_vegp,2) ! thermal resistance [s/m] + real(r8) :: raw(num_nolu_vegp,2) ! moisture resistance [s/m] + real(r8) :: wta ! heat conductance for air [m/s] + real(r8) :: wtg(num_nolu_vegp) ! heat conductance for ground [m/s] + real(r8) :: wtl ! heat conductance for leaf [m/s] + real(r8) :: wta0(num_nolu_vegp) ! normalized heat conductance for air [-] + real(r8) :: wtl0(num_nolu_vegp) ! normalized heat conductance for leaf [-] + real(r8) :: wtg0 ! normalized heat conductance for ground [-] + real(r8) :: wtal(num_nolu_vegp) ! normalized heat conductance for air and leaf [-] + real(r8) :: wtga ! normalized heat cond. for air and ground [-] + real(r8) :: wtaq ! latent heat conductance for air [m/s] + real(r8) :: wtlq ! latent heat conductance for leaf [m/s] + real(r8) :: wtgq(num_nolu_vegp) ! latent heat conductance for ground [m/s] + real(r8) :: wtaq0(num_nolu_vegp) ! normalized latent heat conductance for air [-] + real(r8) :: wtlq0(num_nolu_vegp) ! normalized latent heat conductance for leaf [-] + real(r8) :: wtgq0 ! normalized heat conductance for ground [-] + real(r8) :: wtalq(num_nolu_vegp) ! normalized latent heat cond. for air and leaf [-] + real(r8) :: wtgaq ! normalized latent heat cond. for air and ground [-] + real(r8) :: el(num_nolu_vegp) ! vapor pressure on leaf surface [pa] + real(r8) :: deldT ! derivative of "el" on "t_veg" [pa/K] + real(r8) :: qsatl(num_nolu_vegp) ! leaf specific humidity [kg/kg] + real(r8) :: qsatldT(num_nolu_vegp) ! derivative of "qsatl" on "t_veg" + real(r8) :: e_ref2m ! 2 m height surface saturated vapor pressure [Pa] + real(r8) :: de2mdT ! derivative of 2 m height surface saturated vapor pressure on t_ref2m + real(r8) :: qsat_ref2m ! 2 m height surface saturated specific humidity [kg/kg] + real(r8) :: dqsat2mdT ! derivative of 2 m height surface saturated specific humidity on t_ref2m + real(r8) :: air(num_nolu_vegp) ! atmos. radiation temporay set + real(r8) :: bir(num_nolu_vegp) ! atmos. radiation temporay set + real(r8) :: cir(num_nolu_vegp) ! atmos. radiation temporay set + real(r8) :: dc1,dc2 ! derivative of energy flux [W/m2/K] + real(r8) :: delt ! temporary + real(r8) :: delq(num_nolu_vegp) ! temporary + real(r8) :: del(num_nolu_vegp) ! absolute change in leaf temp in current iteration [K] + real(r8) :: del2(num_nolu_vegp) ! change in leaf temperature in previous iteration [K] + real(r8) :: dele(num_nolu_vegp) ! change in latent heat flux from leaf [K] + real(r8) :: dels ! change in leaf temperature in current iteration [K] + real(r8) :: det(num_nolu_vegp) ! maximum leaf temp. change in two consecutive iter [K] + real(r8) :: efeb(num_nolu_vegp) ! latent heat flux from leaf (previous iter) [mm/s] + real(r8) :: efeold ! latent heat flux from leaf (previous iter) [mm/s] + real(r8) :: efpot ! potential latent energy flux [kg/m2/s] + real(r8) :: efe(num_nolu_vegp) ! water flux from leaf [mm/s] + real(r8) :: efsh ! sensible heat from leaf [mm/s] + real(r8) :: obuold(num_nolu_vegp) ! monin-obukhov length from previous iteration + real(r8) :: tlbef(num_nolu_vegp) ! leaf temperature from previous iteration [K] + real(r8) :: ecidif ! excess energies [W/m2] + real(r8) :: err(num_nolu_vegp) ! balance error + real(r8) :: erre ! balance error + real(r8) :: co2(num_nolu_vegp) ! atmospheric co2 partial pressure (pa) + real(r8) :: o2(num_nolu_vegp) ! atmospheric o2 partial pressure (pa) + real(r8) :: svpts(num_nolu_vegp) ! saturation vapor pressure at t_veg (pa) + real(r8) :: eah(num_nolu_vegp) ! canopy air vapor pressure (pa) + real(r8) :: s_node ! vol_liq/eff_porosity + real(r8) :: smp_node ! matrix potential + real(r8) :: smp_node_lf ! F. Li and S. Levis + real(r8) :: vol_liq ! partial volume of liquid water in layer + integer :: itlef ! counter for leaf temperature iteration [-] + integer :: nmozsgn(num_nolu_vegp) ! number of times stability changes sign + real(r8) :: w ! exp(-LSAI) + real(r8) :: csoilcn ! interpolated csoilc for less than dense canopies + real(r8) :: fm(num_nolu_vegp) ! needed for BGC only to diagnose 10m wind speed + real(r8) :: wtshi ! sensible heat resistance for air, grnd and leaf [-] + real(r8) :: wtsqi ! latent heat resistance for air, grnd and leaf [-] + integer :: j ! soil/snow level index + integer :: p ! patch index + integer :: c ! column index + integer :: l ! landunit index + integer :: t ! topounit index + integer :: g ! gridcell index + integer :: fp ! lake filter pft index + integer :: fn ! number of values in vegetated pft filter + integer :: fnorig ! number of values in pft filter copy + integer :: fporig(num_nolu_vegp) ! temporary filter + integer :: fnold ! temporary copy of pft count + integer :: f ! filter index + logical :: found ! error flag for canopy above forcing hgt + integer :: index ! patch index for error + real(r8) :: egvf ! effective green vegetation fraction + real(r8) :: lt ! elai+esai + real(r8) :: ri ! stability parameter for under canopy air (unitless) + real(r8) :: csoilb ! turbulent transfer coefficient over bare soil (unitless) + real(r8) :: ricsoilc ! modified transfer coefficient under dense canopy (unitless) + real(r8) :: snow_depth_c ! critical snow depth to cover plant litter (m) + real(r8) :: rdl ! dry litter layer resistance for water vapor (s/m) + real(r8) :: elai_dl ! exposed (dry) plant litter area index + real(r8) :: fsno_dl ! effective snow cover over plant litter + real(r8) :: dayl_factor(num_nolu_vegp) ! scalar (0-1) for daylength effect on Vcmax + ! If no unfrozen layers, put all in the top layer. - real(r8) :: rootsum(bounds%begp:bounds%endp) real(r8) :: delt_snow real(r8) :: delt_soil real(r8) :: delt_h2osfc @@ -292,22 +286,19 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & real(r8) :: delq_snow real(r8) :: delq_soil real(r8) :: delq_h2osfc - integer :: local_time ! local time at start of time step (seconds after solar midnight) + integer :: local_time ! local time at start of time step (seconds after solar midnight) integer :: seconds_since_irrig_start_time - integer :: irrig_nsteps_per_day ! number of time steps per day in which we irrigate - logical :: check_for_irrig(bounds%begp:bounds%endp) ! where do we need to check soil moisture to see if we need to irrigate? - logical :: frozen_soil(bounds%begp:bounds%endp) ! set to true if we have encountered a frozen soil layer - real(r8) :: vol_liq_so ! partial volume of liquid water in layer for which smp_node = smpso - real(r8) :: h2osoi_liq_so ! liquid water corresponding to vol_liq_so for this layer [kg/m2] - real(r8) :: h2osoi_liq_sat ! liquid water corresponding to eff_porosity for this layer [kg/m2] - real(r8) :: deficit ! difference between desired soil moisture level for this layer and - ! current soil moisture level [kg/m2] - real(r8) :: dt_veg(bounds%begp:bounds%endp) ! change in t_veg, last iteration (Kelvin) - integer :: jtop(bounds%begc:bounds%endc) ! lbning - integer :: filterc_tmp(bounds%endp-bounds%begp+1) ! temporary variable - integer :: ft ! plant functional type index - real(r8) :: temprootr - real(r8) :: dt_veg_temp(bounds%begp:bounds%endp) + integer :: irrig_nsteps_per_day ! number of time steps per day in which we irrigate + logical :: check_for_irrig(num_nolu_vegp) ! where do we need to check soil moisture to see if we need to irrigate? + logical :: frozen_soil(num_nolu_vegp) ! set to true if we have encountered a frozen soil layer + real(r8) :: vol_liq_so ! partial volume of liquid water in layer for which smp_node = smpso + real(r8) :: h2osoi_liq_so ! liquid water corresponding to vol_liq_so for this layer [kg/m2] + real(r8) :: h2osoi_liq_sat ! liquid water corresponding to eff_porosity for this layer [kg/m2] + real(r8) :: deficit ! difference between desired soil moisture level for this layer and + ! current soil moisture level [kg/m2] + real(r8) :: dt_veg(num_nolu_vegp) ! change in t_veg, last iteration (Kelvin) + integer :: ft ! plant functional type index + real(r8) :: temprootr,sum1 integer :: iv real(r8) :: wind_speed0(bounds%begp:bounds%endp) ! Wind speed from atmosphere at start of iteration real(r8) :: wind_speed_adj(bounds%begp:bounds%endp) ! Adjusted wind speed for iteration @@ -316,6 +307,8 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & real(r8) :: prev_tau(bounds%begp:bounds%endp) ! Previous iteration tau real(r8) :: prev_tau_diff(bounds%begp:bounds%endp) ! Previous difference in iteration tau real(r8) :: slope_rad, deg2rad + integer :: filterp(num_nolu_vegp) ! filter for iteration loop + integer :: converged(num_nolu_vegp), num_unconverged ! Indices for raw and rah integer, parameter :: above_canopy = 1 ! Above canopy @@ -331,20 +324,17 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & max_dayl => grc_pp%max_dayl , & ! Input: [real(r8) (:) ] maximum daylength for this grid cell (s) slope_deg => grc_pp%slope_deg , & - forc_lwrad => top_af%lwrad , & ! Input: [real(r8) (:) ] downward infrared (longwave) radiation (W/m**2) - forc_q => top_as%qbot , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) - forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) - forc_th => top_as%thbot , & ! Input: [real(r8) (:) ] atmospheric potential temperature (Kelvin) - forc_rho => top_as%rhobot , & ! Input: [real(r8) (:) ] air density (kg/m**3) - forc_t => top_as%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) - forc_u => top_as%ubot , & ! Input: [real(r8) (:) ] atmospheric wind speed in east direction (m/s) - forc_v => top_as%vbot , & ! Input: [real(r8) (:) ] atmospheric wind speed in north direction (m/s) - wsresp => top_as%wsresp , & ! Input: [real(r8) (:) ] response of wind to surface stress (m/s/Pa) - tau_est => top_as%tau_est , & ! Input: [real(r8) (:) ] approximate atmosphere change to zonal wind (m/s) - ugust => top_as%ugust , & ! Input: [real(r8) (:) ] gustiness from atmosphere (m/s) - forc_pco2 => top_as%pco2bot , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) - forc_pc13o2 => top_as%pc13o2bot , & ! Input: [real(r8) (:) ] partial pressure c13o2 (Pa) - forc_po2 => top_as%po2bot , & ! Input: [real(r8) (:) ] partial pressure o2 (Pa) + forc_lwrad => top_af%lwrad , & ! Input: [real(r8) (:) ] downward infrared (longwave) radiation (W/m**2) + forc_q => top_as%qbot , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) + forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_th => top_as%thbot , & ! Input: [real(r8) (:) ] atmospheric potential temperature (Kelvin) + forc_rho => top_as%rhobot , & ! Input: [real(r8) (:) ] air density (kg/m**3) + forc_t => top_as%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) + forc_u => top_as%ubot , & ! Input: [real(r8) (:) ] atmospheric wind speed in east direction (m/s) + forc_v => top_as%vbot , & ! Input: [real(r8) (:) ] atmospheric wind speed in north direction (m/s) + forc_pco2 => top_as%pco2bot , & ! Input: [real(r8) (:) ] partial pressure co2 (Pa) + forc_pc13o2 => top_as%pc13o2bot , & ! Input: [real(r8) (:) ] partial pressure c13o2 (Pa) + forc_po2 => top_as%po2bot , & ! Input: [real(r8) (:) ] partial pressure o2 (Pa) dleaf => veg_vp%dleaf , & ! Input: [real(r8) (:) ] characteristic leaf dimension (m) smpso => veg_vp%smpso , & ! Input: [real(r8) (:) ] soil water potential at full stomatal opening (mm) @@ -385,6 +375,13 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & z0qv => frictionvel_vars%z0qv_patch , & ! Output: [real(r8) (:) ] roughness length over vegetation, latent heat [m] rb1 => frictionvel_vars%rb1_patch , & ! Output: [real(r8) (:) ] boundary layer resistance (s/m) num_iter => frictionvel_vars%num_iter_patch , & ! Output: number of iterations required + forc_hgt_t_patch => frictionvel_vars%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] + forc_hgt_q_patch => frictionvel_vars%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] + vds => frictionvel_vars%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) + u10 => frictionvel_vars%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) + u10_elm => frictionvel_vars%u10_elm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) + va => frictionvel_vars%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) + fv => frictionvel_vars%fv_patch , & ! Output: [real(r8) (:) ] friction velocity (m/s) (for dust model) t_h2osfc => col_es%t_h2osfc , & ! Input: [real(r8) (:) ] surface water temperature t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) @@ -468,111 +465,115 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & bsun => energyflux_vars%bsun_patch ! Output:[real(r8) (:) ] sunlit canopy transpiration wetness factor (0 to 1) bsha => energyflux_vars%bsha_patch ! Output:[real(r8) (:) ] sunlit canopy transpiration wetness factor (0 to 1) end if - ! Determine step size - dtime = dtime_mod - !yr = year_curr; mon = mon_curr; day = day_curr; - time = secs_curr; - irrig_nsteps_per_day = ((irrig_length + (dtime - 1))/dtime) ! round up + + fn = num_nolu_vegp ! First - set the following values over points where frac vegetation covered by snow is zero ! (e.g. btran, t_veg, rootr, rresis) - do fp = 1,num_nolakeurbanp - p = filter_nolakeurbanp(fp) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - if (frac_veg_nosno(p) == 0) then + if(num_nolu_barep > 0) then + !$acc parallel loop independent gang vector private(p,c,t) default(present) & + !$acc present(t_veg(:), btran(:), rssun(:), rssha(:), lbl_rsc_h2o(:), thm(:) ) + do fp = 1,num_nolu_barep + p = filter_nolu_barep(fp) + c = veg_pp%column(p) + t = veg_pp%topounit(p) btran(p) = 0._r8 t_veg(p) = forc_t(t) cf_bare = forc_pbot(t)/(SHR_CONST_RGAS*0.001_r8*thm(p))*1.e06_r8 rssun(p) = 1._r8/1.e15_r8 * cf_bare rssha(p) = 1._r8/1.e15_r8 * cf_bare lbl_rsc_h2o(p)=0._r8 - do j = 1, nlevgrnd + end do + !$acc parallel loop independent gang default(present) + do j = 1, nlevgrnd + !$acc loop vector private(p) + do fp = 1,num_nolu_barep + p = filter_nolu_barep(fp) rootr(p,j) = 0._r8 rresis(p,j) = 0._r8 end do - end if - end do - ! ----------------------------------------------------------------- - ! Time step initialization of photosynthesis variables - ! ----------------------------------------------------------------- + end do + + + end if - call photosyns_vars_TimeStepInit(photosyns_vars,bounds) + deg2rad = SHR_CONST_PI/180._r8 + if(num_nolu_vegp == 0) return + time = secs_curr; + irrig_nsteps_per_day = ((irrig_length + (dtime_mod - 1))/dtime_mod) ! round up - ! ----------------------------------------------------------------- - ! Filter patches where frac_veg_nosno IS NON-ZERO - ! ----------------------------------------------------------------- - fn = 0 - do fp = 1,num_nolakeurbanp - p = filter_nolakeurbanp(fp) - if (frac_veg_nosno(p) /= 0) then - fn = fn + 1 - filterp(fn) = p - end if - end do + !$acc enter data copyin(time,irrig_nsteps_per_day) -#ifndef _OPENACC - if (use_fates) then - call alm_fates%prep_canopyfluxes( bounds ) - end if -#endif + !$acc enter data create(del(:), efeb(:), wtlq0(:),wtalq(:), & + !$acc wtgq(:), wtaq0(:), obuold(:),dayl_factor(:),check_for_irrig(:),zldis(:) ) + !$acc enter data create(filterp(:)) - deg2rad = SHR_CONST_PI/180._r8 ! Initialize + !$acc parallel loop independent gang vector private(p) default(present) present(btran(:), btran2(:)) do f = 1, fn + filterp(f) = filter_nolu_vegp(f) p = filterp(f) - del(p) = 0._r8 ! change in leaf temperature from previous iteration - efeb(p) = 0._r8 ! latent head flux from leaf for previous iteration - wtlq0(p) = 0._r8 - wtalq(p) = 0._r8 - wtgq(p) = 0._r8 - wtaq0(p) = 0._r8 - obuold(p) = 0._r8 + del(f) = 0._r8 ! change in leaf temperature from previous iteration + efeb(f) = 0._r8 ! latent head flux from leaf for previous iteration + wtlq0(f) = 0._r8 + wtalq(f) = 0._r8 + wtgq(f) = 0._r8 + wtaq0(f) = 0._r8 + obuold(f) = 0._r8 btran(p) = btran0 btran2(p) = btran0 end do ! calculate daylength control for Vcmax + !$acc parallel loop independent gang vector private(p,g) default(present) do f = 1, fn - p=filterp(f) + p=filter_nolu_vegp(f) g=veg_pp%gridcell(p) ! calculate dayl_factor as the ratio of (current:max dayl)^2 ! set a minimum of 0.01 (1%) for the dayl_factor - dayl_factor(p)=min(1._r8,max(0.01_r8,(dayl(g)*dayl(g))/(max_dayl(g)*max_dayl(g)))) + dayl_factor(f)=min(1._r8,max(0.01_r8,(dayl(g)*dayl(g))/(max_dayl(g)*max_dayl(g)))) end do + ! ----------------------------------------------------------------- + ! Time step initialization of photosynthesis variables + ! ----------------------------------------------------------------- + !NOTE: This likely shouldn't init based on bounds but on a filter !! + call photosyns_vars_TimeStepInit(photosyns_vars,bounds) + if (use_fates) then + call alm_fates%prep_canopyfluxes( bounds ) + end if + rb1(begp:endp) = 0._r8 - !assign the temporary filter - do f = 1, fn - p = filterp(f) - filterc_tmp(f)=veg_pp%column(p) - enddo - !compute effective soil porosity + + !NOTE: this filter set up means doing the same calculations for a column + ! redundantly (eg. computing the same column variable 4 times) + ! It would be best to make nolu_vegc filter. + !assign the temporary filter + + ! compute effective soil porosity call calc_effective_soilporosity(bounds, & ubj = nlevgrnd, & numf = fn, & - filter = filterc_tmp(1:fn), & + filter = filter_nolu_vegp(1:fn), & watsat = watsat(bounds%begc:bounds%endc, 1:nlevgrnd), & h2osoi_ice = h2osoi_ice(bounds%begc:bounds%endc,1:nlevgrnd), & denice = denice, & eff_por=eff_porosity(bounds%begc:bounds%endc, 1:nlevgrnd) ) !compute volumetric liquid water content - jtop(bounds%begc:bounds%endc) = 1 call calc_volumetric_h2oliq(bounds, & - jtop = jtop(bounds%begc:bounds%endc), & lbj = 1, & ubj = nlevgrnd, & numf = fn, & - filter = filterc_tmp(1:fn), & + filter = filter_nolu_vegp(1:fn), & eff_porosity = eff_porosity(bounds%begc:bounds%endc, 1:nlevgrnd), & h2osoi_liq = h2osoi_liq(bounds%begc:bounds%endc, 1:nlevgrnd), & denh2o = denh2o, & vol_liq = h2osoi_liqvol(bounds%begc:bounds%endc, 1:nlevgrnd) ) - !set up perchroot options + ! set up perchroot options call set_perchroot_opt(perchroot, perchroot_alt) ! -------------------------------------------------------------------------- ! if this is a FATES simulation @@ -585,79 +586,70 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! wetness factor btran and the root weighting factors for FATES. These ! values require knowledge of the belowground root structure. ! -------------------------------------------------------------------------- - if(use_fates)then -#ifndef _OPENACC call alm_fates%wrap_btran(bounds, fn, filterc_tmp(1:fn), soilstate_vars, & energyflux_vars, soil_water_retention_curve) -#endif else !calculate root moisture stress call calc_root_moist_stress(bounds, & nlevgrnd = nlevgrnd, & fn = fn, & - filterp = filterp, & + filterp = filter_nolu_vegp, & canopystate_vars=canopystate_vars, & energyflux_vars=energyflux_vars, & soilstate_vars=soilstate_vars & ) - end if !use_fates - ! Determine if irrigation is needed (over irrigated soil columns) + ! Determine if irrigation is needed (over irrigated soil columns) ! First, determine in what grid cells we need to bother 'measuring' soil water, to see if we need irrigation ! Also set n_irrig_steps_left for these grid cells ! n_irrig_steps_left(p) > 0 is ok even if irrig_rate(p) ends up = 0 ! in this case, we'll irrigate by 0 for the given number of time steps + !$acc parallel loop independent gang vector default(present) present(btran(:),elai(:),n_irrig_steps_left(:), irrig_rate(:)) private(p,g,local_time,seconds_since_irrig_start_time) do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) + p = filter_nolu_vegp(f) g = veg_pp%gridcell(p) if ( .not.veg_pp%is_fates(p) .and. & irrigated(veg_pp%itype(p)) == 1._r8 .and. & - elai(p) > irrig_min_lai .and. & - btran(p) < irrig_btran_thresh ) then + elai(p) > irrig_min_lai .and. btran(p) < irrig_btran_thresh ) then ! see if it's the right time of day to start irrigating: - local_time = modulo(time + nint(grc_pp%londeg(g)/degpsec), isecspday) + local_time = modulo(secs_curr + nint(grc_pp%londeg(g)/degpsec), isecspday) seconds_since_irrig_start_time = modulo(local_time - irrig_start_time, isecspday) - if (seconds_since_irrig_start_time < dtime) then + if (seconds_since_irrig_start_time < dtime_mod) then ! it's time to start irrigating - check_for_irrig(p) = .true. + check_for_irrig(f) = .true. n_irrig_steps_left(p) = irrig_nsteps_per_day irrig_rate(p) = 0._r8 ! reset; we'll add to this later else - check_for_irrig(p) = .false. + check_for_irrig(f) = .false. end if else ! non-irrig pft or elai<=irrig_min_lai or btran>irrig_btran_thresh - check_for_irrig(p) = .false. + check_for_irrig(f) = .false. end if end do - ! Now 'measure' soil water for the grid cells identified above and see if the ! soil is dry enough to warrant irrigation ! (Note: frozen_soil could probably be a column-level variable, but that would be ! slightly less robust to potential future modifications) ! This should not be operating on FATES patches (see is_fates filter above, pushes ! check_for_irrig = false - frozen_soil(bounds%begp : bounds%endp) = .false. - do j = 1,nlevgrnd - do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - tpu_ind = top_pp%topo_grc_ind(t) !Get topounit index on the grid - g = veg_pp%gridcell(p) - if (check_for_irrig(p) .and. .not. frozen_soil(p)) then + ! frozen_soil(1:fn) = .false. + !$acc parallel loop independent gang worker default(present) private(p,c,g) + do f = 1, fn + p = filter_nolu_vegp(f) + c = veg_pp%column(p) + g = veg_pp%gridcell(p) + if (check_for_irrig(f)) then + !$acc loop vector reduction(+:sum1) private(vol_liq_so,h2osoi_liq_so,h2osoi_liq_sat,deficit) + do j = 1,nlevgrnd ! if level L was frozen, then we don't look at any levels below L - if (t_soisno(c,j) <= SHR_CONST_TKFRZ) then - frozen_soil(p) = .true. - else if (rootfr(p,j) > 0._r8) then + if (t_soisno(c,j) > SHR_CONST_TKFRZ .and. rootfr(p,j) > 0._r8) then ! determine soil water deficit in this layer: - ! Calculate vol_liq_so - i.e., vol_liq at which smp_node = smpso - by inverting the above equations ! for the root resistance factors vol_liq_so = eff_porosity(c,j) * (-smpso(veg_pp%itype(p))/sucsat(c,j))**(-1/bsw(c,j)) @@ -668,16 +660,21 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & deficit = max((h2osoi_liq_so + firrig(g,tpu_ind)*(h2osoi_liq_sat - h2osoi_liq_so)) - h2osoi_liq(c,j), 0._r8) ! Add deficit to irrig_rate, converting units from mm to mm/sec - irrig_rate(p) = irrig_rate(p) + deficit/(dtime*irrig_nsteps_per_day) + sum1 = sum1 + deficit/(dtime_mod*irrig_nsteps_per_day) end if ! else if (rootfr(p,j) > 0) - end if ! if (check_for_irrig(p) .and. .not. frozen_soil(p)) - end do ! do f - end do ! do j + end do ! do j + irrig_rate(p) = sum1 + end if ! if (check_for_irrig(f) .and. .not. frozen_soil(f)) + end do ! do f + + found = .false. ! Modify aerodynamic parameters for sparse/dense canopy (X. Zeng) + !$acc parallel loop independent gang vector default(present) private(p,c,egvf,lt) & + !$acc present(z0qv(:),forc_hgt_u_patch(:),elai(:),displa(:),esai(:),z0hv(:),z0mg(:),z0mv(:)) do f = 1, fn - p = filterp(f) + p = filter_nolu_vegp(f) c = veg_pp%column(p) lt = min(elai(p)+esai(p), tlsai_crit) @@ -686,21 +683,29 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & z0mv(p) = exp(egvf * log(z0mv(p)) + (1._r8 - egvf) * log(z0mg(c))) z0hv(p) = z0mv(p) z0qv(p) = z0mv(p) + + !!Moved this here to allow async compute/data create w/ loop below + zldis(f) = forc_hgt_u_patch(p) - displa(p) + end do - found = .false. + !$acc enter data create(air(:),bir(:), cir(:), co2(:),o2(:),& + !$acc nmozsgn(:), taf(:),qaf(:), ur(:),dth(:),dqh(:),delq(:), & + !$acc dthv(:), obu(:),el(:),qsatl(:),qsatldT(:), um(:), & + !$acc wta0(:), err(:), det(:)) + + !$acc parallel loop independent gang vector default(present) private(p,c,t,g,deldT) present(thm(:),emv(:)) do f = 1, fn - p = filterp(f) + p = filter_nolu_vegp(f) c = veg_pp%column(p) t = veg_pp%topounit(p) g = veg_pp%gridcell(p) ! Net absorbed longwave radiation by canopy and ground ! =air+bir*t_veg**4+cir*t_grnd(c)**4 - - air(p) = emv(p) * (1._r8+(1._r8-emv(p))*(1._r8-emg(c))) * forc_lwrad(t) - bir(p) = - (2._r8-emv(p)*(1._r8-emg(c))) * emv(p) * sb - cir(p) = emv(p)*emg(c)*sb + air(f) = emv(p) * (1._r8+(1._r8-emv(p))*(1._r8-emg(c))) * forc_lwrad(t) + bir(f) = - (2._r8-emv(p)*(1._r8-emg(c))) * emv(p) * sb + cir(f) = emv(p)*emg(c)*sb if (use_finetop_rad) then slope_rad = slope_deg(g) * deg2rad @@ -710,103 +715,88 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! Saturated vapor pressure, specific humidity, and their derivatives ! at the leaf surface - call QSat (t_veg(p), forc_pbot(t), el(p), deldT, qsatl(p), qsatldT(p)) + call QSat (t_veg(p), forc_pbot(t), el(f), deldT, qsatl(f), qsatldT(f)) ! Determine atmospheric co2 and o2 - co2(p) = forc_pco2(t) - o2(p) = forc_po2(t) - - if ( use_c13 ) then - c13o2(p) = forc_pc13o2(t) - end if + co2(f) = forc_pco2(t) + o2(f) = forc_po2(t) ! Initialize flux profile + nmozsgn(f) = 0 - nmozsgn(p) = 0 - - taf(p) = (t_grnd(c) + thm(p))/2._r8 - qaf(p) = (forc_q(t)+qg(c))/2._r8 - - ! Initialize winds for iteration. - if (implicit_stress) then - wind_speed0(p) = max(0.01_r8, hypot(forc_u(t), forc_v(t))) - wind_speed_adj(p) = wind_speed0(p) - ur(p) = max(1.0_r8, sqrt(wind_speed_adj(p)**2 + ugust(t)**2)) - - prev_tau(p) = tau_est(t) - else - ur(p) = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t)+ugust(t)*ugust(t))) - end if - tau_diff(p) = 1.e100_r8 - ugust_total(p) = ugust(t) - - dth(p) = thm(p)-taf(p) - dqh(p) = forc_q(t)-qaf(p) - delq(p) = qg(c) - qaf(p) - dthv(p) = dth(p)*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh(p) - zldis(p) = forc_hgt_u_patch(p) - displa(p) + taf(f) = (t_grnd(c) + thm(p))/2._r8 + qaf(f) = (forc_q(t)+qg(c))/2._r8 - - ! Check to see if the forcing height is below the canopy height - if (zldis(p) < 0._r8) then - found = .true. - index = p - end if + ur(f) = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t))) + dth(f) = thm(p)-taf(f) + dqh(f) = forc_q(t)-qaf(f) + delq(f) = qg(c) - qaf(f) + dthv(f) = dth(f)*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh(f) end do if (found) then if ( .not. use_fates ) then -#ifndef _OPENACC - write(iulog,*)'Error: Forcing height is below canopy height for pft index ' + write(*,*)'Error: Forcing height is below canopy height for pft index ' call endrun(decomp_index=index, elmlevel=namep, msg=errmsg(__FILE__, __LINE__)) -#endif end if end if - + + !$acc enter data create(converged(:) ) + !$acc parallel loop independent gang vector default(present) private(p,c) do f = 1, fn - p = filterp(f) + p = filter_nolu_vegp(f) c = veg_pp%column(p) + converged(f) = 0 + ! Initialize Monin-Obukhov length and wind speed - ! Initialize Obukhov length scale and wind speed - - call MoninObukIni(ur(p), thv(c), dthv(p), zldis(p), z0mv(p), um(p), obu(p)) num_iter(p) = 0._r8 - + call MoninObukIni(ur(f), thv(c), dthv(f), zldis(f), z0mv(p), um(f), obu(f)) + end do ! Set counter for leaf temperature iteration (itlef) - - itlef = 1 - fnorig = fn - fporig(1:fn) = filterp(1:fn) - + num_unconverged = num_nolu_vegp + itlef = 0 + !$acc enter data copyin(itlef) create(temp1(:), temp2(:),temp12m(:),& + !$acc temp22m(:),ustar(:),rah(:,:),raw(:,:), uaf(:),rb(:), & + !$acc tlbef(:), del(:),del2(:),svpts(:),eah(:), dt_veg(:),wtg(:), & + !$acc wtl0(:), wtal(:), efe(:), dele(:),fm(:)) + ! Begin stability iteration call t_startf('can_iter') - ITERATION : do while (itlef <= itmax .and. fn > 0) - - ! Determine friction velocity, and potential temperature and humidity - ! profiles of the surface boundary layer - call FrictionVelocity (begp, endp, fn, filterp, & - displa(begp:endp), z0mv(begp:endp), z0hv(begp:endp), z0qv(begp:endp), & - obu(begp:endp), itlef, ur(begp:endp), um(begp:endp), ugust_total(begp:endp), ustar(begp:endp), & - temp1(begp:endp), temp2(begp:endp), temp12m(begp:endp), temp22m(begp:endp), fm(begp:endp), & - frictionvel_vars) - - do f = 1, fn + event = 'can_iter' + ITERATION : do while (itlef <= itmax .and. num_unconverged > 0) + !$acc update device(itlef) + !$acc parallel loop independent gang vector default(present) + do f = 1, fn + if(converged(f)) cycle p = filterp(f) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) + call FrictionVelocity_noloop ( & + displa(p), z0mv(p), z0hv(p), z0qv(p), & + obu(f), itlef+1, ur(f), um(f), ustar(f), & + temp1(f), temp2(f), temp12m(f), temp22m(f), fm(f), & + forc_hgt_u_patch(p), forc_hgt_t_patch(p), forc_hgt_q_patch(p), & + vds(p), u10(p), u10_elm(p), va(p), fv(p)) + end do + !$acc parallel loop independent gang vector default(present) private(p,c,t,g,& + !$acc cf, w,csoilb,ri, ricsoilc, csoilcn) present(ram1(:), rb1(:), rhaf(:),grnd_ch4_cond(:),t_veg(:),elai(:),btran(:),& + !$acc esai(:), temp2(:), htop(:), dleaf_patch(:), rah(:,:)) + do f = 1, fn + if(converged(f)) cycle + p = filterp(f) + c = veg_pp%column(p) + t = veg_pp%topounit(p) + g = veg_pp%gridcell(p) - tlbef(p) = t_veg(p) - del2(p) = del(p) + tlbef(f) = t_veg(p) !not used right now? + del2(f) = del(f) ! also not used in this loop ! Determine aerodynamic resistances - ram1(p) = 1._r8/(ustar(p)*ustar(p)/um(p)) - rah(p,above_canopy) = 1._r8/(temp1(p)*ustar(p)) - raw(p,above_canopy) = 1._r8/(temp2(p)*ustar(p)) + ram1(p) = 1._r8/(ustar(f)*ustar(f)/um(f)) + rah(f,above_canopy) = 1._r8/(temp1(f)*ustar(f)) + raw(f,above_canopy) = 1._r8/(temp2(f)*ustar(f)) ! Forbid removing more than 99% of wind speed in a time step. ! This is mainly to avoid convergence issues since this is such a @@ -820,8 +810,7 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & end if ! Bulk boundary layer resistance of leaves - - uaf(p) = um(p)*sqrt( 1._r8/(ram1(p)*um(p)) ) + uaf(f) = um(f)*sqrt( 1._r8/(ram1(p)*um(f)) ) ! Use pft parameter for leaf characteristic width ! dleaf_patch if this is not an ed patch. @@ -832,9 +821,9 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & end if - cf = 0.01_r8/(sqrt(uaf(p))*sqrt( dleaf_patch(p) )) - rb(p) = 1._r8/(cf*uaf(p)) - rb1(p) = rb(p) + cf = 0.01_r8/(sqrt(uaf(f))*sqrt( dleaf_patch(p) )) + rb(f) = 1._r8/(cf*uaf(f)) + rb1(p) = rb(f) !NOTE: this doesn't need to be updated every iteration ! Parameterization for variation of csoilc with canopy density from ! X. Zeng, University of Arizona @@ -844,15 +833,15 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! changed by K.Sakaguchi from here ! transfer coefficient over bare soil is changed to a local variable ! just for readability of the code (from line 680) - csoilb = (vkc/(0.13_r8*(z0mg(c)*uaf(p)/1.5e-5_r8)**0.45_r8)) + csoilb = (vkc/(0.13_r8*(z0mg(c)*uaf(f)/1.5e-5_r8)**0.45_r8)) !compute the stability parameter for ricsoilc ("S" in Sakaguchi&Zeng,2008) - ri = ( grav*htop(p) * (taf(p) - t_grnd(c)) ) / (taf(p) * uaf(p) **2.00_r8) + ri = ( grav*htop(p) * (taf(f) - t_grnd(c)) ) / (taf(f) * uaf(f) **2.00_r8) !! modify csoilc value (0.004) if the under-canopy is in stable condition - if ( (taf(p) - t_grnd(c) ) > 0._r8) then + if ( (taf(f) - t_grnd(c) ) > 0._r8) then ! decrease the value of csoilc by dividing it with (1+gamma*min(S, 10.0)) ! ria ("gmanna" in Sakaguchi&Zeng, 2008) is a constant (=0.5) ricsoilc = csoilc / (1.00_r8 + ria*min( ri, 10.0_r8) ) @@ -863,26 +852,18 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & !! Sakaguchi changes for stability formulation ends here - rah(p,below_canopy) = 1._r8/(csoilcn*uaf(p)) - raw(p,below_canopy) = rah(p,below_canopy) + rah(f,below_canopy) = 1._r8/(csoilcn*uaf(f)) + raw(f,below_canopy) = rah(f,below_canopy) if (use_lch4) then - grnd_ch4_cond(p) = 1._r8/(raw(p,above_canopy)+raw(p,below_canopy)) + grnd_ch4_cond(p) = 1._r8/(raw(f,above_canopy)+raw(f,below_canopy)) end if ! Stomatal resistances for sunlit and shaded fractions of canopy. ! Done each iteration to account for differences in eah, tv. - svpts(p) = el(p) ! Pa - eah(p) = forc_pbot(t) * qaf(p) / mm_epsilon ! Pa - rhaf(p) = eah(p)/svpts(p) - - ! variables for history fields - rah_above(p) = rah(p,above_canopy) - raw_above(p) = raw(p,above_canopy) - rah_below(p) = rah(p,below_canopy) - raw_below(p) = raw(p,below_canopy) - vpd(p) = max((svpts(p) - eah(p)), vpd_min) * pa_to_kpa ! kPa - end do + svpts(f) = el(f) ! pa + eah(f) = forc_pbot(t) * qaf(f) / 0.622_r8 ! pa + rhaf(p) = eah(f)/svpts(f) ! Modification for shrubs proposed by X.D.Z ! Equivalent modification for soy following AgroIBIS @@ -893,26 +874,20 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! BUG MV 4/7/2014 - is this the correct place to have it in the iteration? ! THIS SHOULD BE MOVED OUT OF THE ITERATION but will change answers - - do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) if(.not.veg_pp%is_fates(p)) then - ! soybean (crop with N fixation) if (crop(veg_pp%itype(p)) >= 1 .and. nfixer(veg_pp%itype(p)) == 1) then - btran(p) = min(1._r8, btran(p) * 1.25_r8) end if end if - end do + + end do if ( use_fates ) then -#ifndef _OPENACC call alm_fates%wrap_photosynthesis(bounds, fn, filterp(1:fn), & svpts(begp:endp), eah(begp:endp), o2(begp:endp), & co2(begp:endp), rb(begp:endp), dayl_factor(begp:endp), & atm2lnd_vars, canopystate_vars, photosyns_vars) -#endif else ! not use_fates if ( use_hydrstress ) then @@ -923,18 +898,26 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & atm2lnd_vars, soilstate_vars, surfalb_vars, solarabs_vars, & canopystate_vars, photosyns_vars) else - call Photosynthesis (bounds, fn, filterp, & - svpts(begp:endp), eah(begp:endp), o2(begp:endp), co2(begp:endp), rb(begp:endp), btran(begp:endp), & - dayl_factor(begp:endp), atm2lnd_vars, surfalb_vars, solarabs_vars, & - canopystate_vars, photosyns_vars, 'sun') + call Photosynthesis(bounds,num_nolu_vegp,filterp,converged(1:num_nolu_vegp),& + svpts(1:num_nolu_vegp), eah(1:num_nolu_vegp),o2(1:num_nolu_vegp),& + co2(1:num_nolu_vegp), rb(1:num_nolu_vegp), btran(begp:endp), dayl_factor(1:num_nolu_vegp),& + surfalb_vars, solarabs_vars, canopystate_vars, photosyns_vars, 'sun', & + solarabs_vars%parsun_z_patch(begp:endp,:), canopystate_vars%laisun_z_patch(begp:endp,:), & + surfalb_vars%vcmaxcintsun_patch(begp:endp), photosyns_vars%alphapsnsun_patch(begp:endp), & + photosyns_vars%cisun_z_patch(begp:endp,:), photosyns_vars%rssun_patch(begp:endp), & + photosyns_vars%rssun_z_patch(begp:endp,:), photosyns_vars%lmrsun_patch(begp:endp), & + photosyns_vars%lmrsun_z_patch(begp:endp,:), photosyns_vars%psnsun_patch(begp:endp), & + photosyns_vars%psnsun_z_patch(begp:endp,:),photosyns_vars%psnsun_wc_patch(begp:endp), & + photosyns_vars%psnsun_wj_patch(begp:endp),photosyns_vars%psnsun_wp_patch(begp:endp) ) + end if if ( use_c13 ) then call Fractionation (bounds, fn, filterp, & - cnstate_vars, solarabs_vars, surfalb_vars, photosyns_vars, & - 1) + cnstate_vars, solarabs_vars, surfalb_vars, photosyns_vars, 1) endif + !$acc parallel loop independent gang vector default(present) private(p,c) do f = 1, fn p = filterp(f) c = veg_pp%column(p) @@ -945,22 +928,32 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & end do if ( .not. use_hydrstress ) then - call Photosynthesis (bounds, fn, filterp, & - svpts(begp:endp), eah(begp:endp), o2(begp:endp), co2(begp:endp), rb(begp:endp), btran(begp:endp), & - dayl_factor(begp:endp), atm2lnd_vars,surfalb_vars, solarabs_vars, & - canopystate_vars, photosyns_vars, 'sha') - end if + call Photosynthesis(bounds,fn,filterp,converged, & + svpts(1:num_nolu_vegp), eah(1:num_nolu_vegp),o2(1:num_nolu_vegp),& + co2(1:num_nolu_vegp),rb(1:num_nolu_vegp), btran(begp:endp), dayl_factor(1:num_nolu_vegp),& + surfalb_vars, solarabs_vars, canopystate_vars, photosyns_vars, 'sha', & + solarabs_vars%parsha_z_patch(begp:endp,:), canopystate_vars%laisha_z_patch(begp:endp,:), & + surfalb_vars%vcmaxcintsha_patch(begp:endp), photosyns_vars%alphapsnsha_patch(begp:endp), & + photosyns_vars%cisha_z_patch(begp:endp,:),photosyns_vars%rssha_patch(begp:endp), & + photosyns_vars%rssha_z_patch(begp:endp,:),photosyns_vars%lmrsha_patch(begp:endp), & + photosyns_vars%lmrsha_z_patch(begp:endp,:),photosyns_vars%psnsha_patch(begp:endp),& + photosyns_vars%psnsha_z_patch(begp:endp,:),photosyns_vars%psnsha_wc_patch(begp:endp),& + photosyns_vars%psnsha_wj_patch(begp:endp),photosyns_vars%psnsha_wp_patch(begp:endp) ) + end if if ( use_c13 ) then call Fractionation (bounds, fn, filterp, & - cnstate_vars, solarabs_vars, surfalb_vars, photosyns_vars, & - 0) + cnstate_vars, solarabs_vars, surfalb_vars, photosyns_vars, 0) end if end if ! end of if use_fates + !$acc parallel loop independent gang vector default(present) present(laisun(:),& + !$acc thm(:), canopy_cond(:),temp2(:), frac_veg_nosno(:), esai(:), fdry(:), wta0(:), h2ocan(:), & + !$acc laisha(:),rssha(:),btran(:), fwet(:), qflx_evap_veg(:), qflx_tran_veg(:),sabv(:), eflx_sh_veg(:) ) do f = 1, fn + if(converged(f)) cycle p = filterp(f) c = veg_pp%column(p) t = veg_pp%topounit(p) @@ -969,32 +962,32 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! Sensible heat conductance for air, leaf and ground ! Moved the original subroutine in-line... - wta = 1._r8/rah(p,above_canopy) ! air - wtl = (elai(p)+esai(p))/rb(p) ! leaf - wtg(p) = 1._r8/rah(p,below_canopy) ! ground - wtshi = 1._r8/(wta+wtl+wtg(p)) - wtl0(p) = wtl*wtshi ! leaf - wtg0 = wtg(p)*wtshi ! ground - wta0(p) = wta*wtshi ! air + wta = 1._r8/rah(f,above_canopy) ! air + wtl = (elai(p)+esai(p))/rb(f) ! leaf + wtg(f) = 1._r8/rah(f,below_canopy) ! ground + wtshi = 1._r8/(wta+wtl+wtg(f)) + wtl0(f) = wtl*wtshi ! leaf + wtg0 = wtg(f)*wtshi ! ground + wta0(f) = wta*wtshi ! air - wtga = wta0(p)+wtg0 ! ground + air - wtal(p) = wta0(p)+wtl0(p) ! air + leaf + wtga = wta0(f)+wtg0 ! ground + air + wtal(f) = wta0(f)+wtl0(f) ! air + leaf ! Fraction of potential evaporation from leaf if (fdry(p) > 0._r8) then - rppdry = fdry(p)*rb(p)*(laisun(p)/(rb(p)+rssun(p)) + & - laisha(p)/(rb(p)+rssha(p)))/elai(p) + rppdry = fdry(p)*rb(f)*(laisun(p)/(rb(f)+rssun(p)) + & + laisha(p)/(rb(f)+rssha(p)))/elai(p) else rppdry = 0._r8 end if ! Calculate canopy conductance for methane / oxygen (e.g. stomatal conductance & leaf bdy cond) if (use_lch4) then - canopy_cond(p) = (laisun(p)/(rb(p)+rssun(p)) + laisha(p)/(rb(p)+rssha(p)))/max(elai(p), 0.01_r8) + canopy_cond(p) = (laisun(p)/(rb(f)+rssun(p)) + laisha(p)/(rb(f)+rssha(p)))/max(elai(p), 0.01_r8) end if - efpot = forc_rho(t)*wtl*(qsatl(p)-qaf(p)) + efpot = forc_rho(t)*wtl*(qsatl(f)-qaf(f)) ! When the hydraulic stress parameterization is active calculate rpp ! but not transpiration if ( use_hydrstress ) then @@ -1005,7 +998,7 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & rpp = fwet(p) end if !Check total evapotranspiration from leaves - rpp = min(rpp, (qflx_tran_veg(p)+h2ocan(p)/dtime)/efpot) + rpp = min(rpp, (qflx_tran_veg(p)+h2ocan(p)/dtime_mod)/efpot) else rpp = 1._r8 end if @@ -1021,7 +1014,7 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & qflx_tran_veg(p) = 0._r8 end if !Check total evapotranspiration from leaves - rpp = min(rpp, (qflx_tran_veg(p)+h2ocan(p)/dtime)/efpot) + rpp = min(rpp, (qflx_tran_veg(p)+h2ocan(p)/dtime_mod)/efpot) else !No transpiration if potential evaporation less than zero rpp = 1._r8 @@ -1033,66 +1026,66 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! Air has same conductance for both sensible and latent heat. ! Moved the original subroutine in-line... - wtaq = frac_veg_nosno(p)/raw(p,above_canopy) ! air - wtlq = frac_veg_nosno(p)*(elai(p)+esai(p))/rb(p) * rpp ! leaf + wtaq = frac_veg_nosno(p)/raw(f,above_canopy) ! air + wtlq = frac_veg_nosno(p)*(elai(p)+esai(p))/rb(f) * rpp ! leaf !Litter layer resistance. Added by K.Sakaguchi snow_depth_c = z_dl ! critical depth for 100% litter burial by snow (=litter thickness) fsno_dl = snow_depth(c)/snow_depth_c ! effective snow cover for (dry)plant litter elai_dl = lai_dl*(1._r8 - min(fsno_dl,1._r8)) ! exposed (dry)litter area index - rdl = ( 1._r8 - exp(-elai_dl) ) / ( 0.004_r8*uaf(p)) ! dry litter layer resistance + rdl = ( 1._r8 - exp(-elai_dl) ) / ( 0.004_r8*uaf(f)) ! dry litter layer resistance ! add litter resistance and Lee and Pielke 1992 beta - if (delq(p) < 0._r8) then !dew. Do not apply beta for negative flux (follow old rsoil) - wtgq(p) = frac_veg_nosno(p)/(raw(p,below_canopy)+rdl) + if (delq(f) < 0._r8) then !dew. Do not apply beta for negative flux (follow old rsoil) + wtgq(f) = frac_veg_nosno(p)/(raw(f,below_canopy)+rdl) else if (do_soilevap_beta()) then - wtgq(p) = soilbeta(c)*frac_veg_nosno(p)/(raw(p,below_canopy)+rdl) + wtgq(f) = soilbeta(c)*frac_veg_nosno(p)/(raw(f,below_canopy)+rdl) endif end if - wtsqi = 1._r8/(wtaq+wtlq+wtgq(p)) + wtsqi = 1._r8/(wtaq+wtlq+wtgq(f)) - wtgq0 = wtgq(p)*wtsqi ! ground - wtlq0(p) = wtlq*wtsqi ! leaf - wtaq0(p) = wtaq*wtsqi ! air + wtgq0 = wtgq(f)*wtsqi ! ground + wtlq0(f) = wtlq*wtsqi ! leaf + wtaq0(f) = wtaq*wtsqi ! air - wtgaq = wtaq0(p)+wtgq0 ! air + ground - wtalq(p) = wtaq0(p)+wtlq0(p) ! air + leaf + wtgaq = wtaq0(f)+wtgq0 ! air + ground + wtalq(f) = wtaq0(f)+wtlq0(f) ! air + leaf dc1 = forc_rho(t)*cpair*wtl dc2 = hvap*forc_rho(t)*wtlq - efsh = dc1*(wtga*t_veg(p)-wtg0*t_grnd(c)-wta0(p)*thm(p)) - efe(p) = dc2*(wtgaq*qsatl(p)-wtgq0*qg(c)-wtaq0(p)*forc_q(t)) + efsh = dc1*(wtga*t_veg(p)-wtg0*t_grnd(c)-wta0(f)*thm(p)) + efe(f) = dc2*(wtgaq*qsatl(f)-wtgq0*qg(c)-wtaq0(f)*forc_q(t)) ! Evaporation flux from foliage erre = 0._r8 - if (efe(p)*efeb(p) < 0._r8) then - efeold = efe(p) - efe(p) = 0.1_r8*efeold - erre = efe(p) - efeold + if (efe(f)*efeb(f) < 0._r8) then + efeold = efe(f) + efe(f) = 0.1_r8*efeold + erre = efe(f) - efeold end if ! fractionate ground emitted longwave lw_grnd=(frac_sno(c)*t_soisno(c,snl(c)+1)**4 & +(1._r8-frac_sno(c)-frac_h2osfc(c))*t_soisno(c,1)**4 & +frac_h2osfc(c)*t_h2osfc(c)**4) - dt_veg(p) = (sabv(p) + air(p) + bir(p)*t_veg(p)**4 + & - cir(p)*lw_grnd - efsh - efe(p)) / & - (- 4._r8*bir(p)*t_veg(p)**3 +dc1*wtga +dc2*wtgaq*qsatldT(p)) - t_veg(p) = tlbef(p) + dt_veg(p) - dels = dt_veg(p) - del(p) = abs(dels) - err(p) = 0._r8 - if (del(p) > delmax) then - dt_veg(p) = delmax*dels/del(p) - t_veg(p) = tlbef(p) + dt_veg(p) - err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + & - 4._r8*dt_veg(p)) + cir(p)*lw_grnd - & - (efsh + dc1*wtga*dt_veg(p)) - (efe(p) + & - dc2*wtgaq*qsatldT(p)*dt_veg(p)) + dt_veg(f) = (sabv(p) + air(f) + bir(f)*t_veg(p)**4 + & + cir(f)*lw_grnd - efsh - efe(f)) / & + (- 4._r8*bir(f)*t_veg(p)**3 +dc1*wtga +dc2*wtgaq*qsatldT(f)) + t_veg(p) = tlbef(f) + dt_veg(f) + dels = dt_veg(f) + del(f) = abs(dels) + err(f) = 0._r8 + if (del(f) > delmax) then + dt_veg(f) = delmax*dels/del(f) + t_veg(p) = tlbef(f) + dt_veg(f) + err(f) = sabv(p) + air(f) + bir(f)*tlbef(f)**3*(tlbef(f) + & + 4._r8*dt_veg(f)) + cir(f)*lw_grnd - & + (efsh + dc1*wtga*dt_veg(f)) - (efe(f) + & + dc2*wtgaq*qsatldT(f)*dt_veg(f)) end if ! Fluxes from leaves to canopy space @@ -1100,8 +1093,8 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! result in an imbalance in "hvap*qflx_evap_veg" and ! "efe + dc2*wtgaq*qsatdt_veg" - efpot = forc_rho(t)*wtl*(wtgaq*(qsatl(p)+qsatldT(p)*dt_veg(p)) & - -wtgq0*qg(c)-wtaq0(p)*forc_q(t)) + efpot = forc_rho(t)*wtl*(wtgaq*(qsatl(f)+qsatldT(f)*dt_veg(f)) & + -wtgq0*qg(c)-wtaq0(f)*forc_q(t)) qflx_evap_veg(p) = rpp*efpot ! Calculation of evaporative potentials (efpot) and @@ -1110,8 +1103,8 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & ! during the timestep. This energy is later added to the ! sensible heat flux. if ( use_hydrstress ) then - ecidif = max(0._r8,qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan(p)/dtime) - qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan(p)/dtime) + ecidif = max(0._r8,qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan(p)/dtime_mod) + qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan(p)/dtime_mod) else ecidif = 0._r8 @@ -1120,97 +1113,97 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & else qflx_tran_veg(p) = 0._r8 end if - ecidif = max(0._r8, qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan(p)/dtime) - qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan(p)/dtime) + ecidif = max(0._r8, qflx_evap_veg(p)-qflx_tran_veg(p)-h2ocan(p)/dtime_mod) + qflx_evap_veg(p) = min(qflx_evap_veg(p),qflx_tran_veg(p)+h2ocan(p)/dtime_mod) end if ! The energy loss due to above two limits is added to ! the sensible heat flux. - eflx_sh_veg(p) = efsh + dc1*wtga*dt_veg(p) + err(p) + erre + hvap*ecidif + eflx_sh_veg(p) = efsh + dc1*wtga*dt_veg(f) + err(f) + erre + hvap*ecidif ! Re-calculate saturated vapor pressure, specific humidity, and their ! derivatives at the leaf surface - call QSat(t_veg(p), forc_pbot(t), el(p), deldT, qsatl(p), qsatldT(p)) + call QSat(t_veg(p), forc_pbot(t), el(f), deldT, qsatl(f), qsatldT(f)) ! Update vegetation/ground surface temperature, canopy air ! temperature, canopy vapor pressure, aerodynamic temperature, and ! Monin-Obukhov stability parameter for next iteration. - taf(p) = wtg0*t_grnd(c) + wta0(p)*thm(p) + wtl0(p)*t_veg(p) - qaf(p) = wtlq0(p)*qsatl(p) + wtgq0*qg(c) + forc_q(t)*wtaq0(p) + taf(f) = wtg0*t_grnd(c) + wta0(f)*thm(p) + wtl0(f)*t_veg(p) + qaf(f) = wtlq0(f)*qsatl(f) + wtgq0*qg(c) + forc_q(t)*wtaq0(f) ! Update Obukhov length scale and wind speed including the ! stability effect - dth(p) = thm(p)-taf(p) - dqh(p) = forc_q(t)-qaf(p) - delq(p) = wtalq(p)*qg(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(t) + dth(f) = thm(p)-taf(f) + dqh(f) = forc_q(t)-qaf(f) + delq(f) = wtalq(f)*qg(c)-wtlq0(f)*qsatl(f)-wtaq0(f)*forc_q(t) - tstar = temp1(p)*dth(p) - qstar = temp2(p)*dqh(p) + tstar = temp1(f)*dth(f) + qstar = temp2(f)*dqh(f) thvstar = tstar*(1._r8+0.61_r8*forc_q(t)) + 0.61_r8*forc_th(t)*qstar - zeta(p) = zldis(p)*vkc*grav*thvstar/(ustar(p)**2*thv(c)) - if (zeta(p) >= 0._r8) then !stable - zeta(p) = min(2._r8,max(zeta(p),0.01_r8)) - um(p) = max(ur(p),0.1_r8) + zeta = zldis(f)*vkc*grav*thvstar/(ustar(f)**2*thv(c)) + if (zeta >= 0._r8) then !stable + zeta = min(2._r8,max(zeta,0.01_r8)) + um(f) = max(ur(f),0.1_r8) else !unstable - zeta(p) = max(-100._r8,min(zeta(p),-0.01_r8)) + zeta = max(-100._r8,min(zeta,-0.01_r8)) if ((.not. atm_gustiness) .or. force_land_gustiness) then - wc = beta*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8 + wc = beta*(-grav*ustar(f)*thvstar*zii/thv(c))**0.333_r8 ugust_total(p) = sqrt(ugust(t)**2 + wc**2) - um(p) = sqrt(ur(p)*ur(p)+wc*wc) + um(f) = sqrt(ur(f)*ur(f)+wc*wc) else - um(p) = max(ur(p),0.1_r8) + um(f) = max(ur(f),0.1_r8) end if end if - obu(p) = zldis(p)/zeta(p) + obu(f) = zldis(f)/zeta - if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1 - if (nmozsgn(p) >= 4) obu(p) = zldis(p)/(-0.01_r8) - obuold(p) = obu(p) + if (obuold(f)*obu(f) < 0._r8) nmozsgn(f) = nmozsgn(f)+1 + if (nmozsgn(f) >= 4) obu(f) = zldis(f)/(-0.01_r8) + obuold(f) = obu(f) end do ! end of filtered pft loop + !$acc parallel loop independent gang vector default(present) private(p,t) do f = 1, fn + if(converged(f)) cycle p = filterp(f) t = veg_pp%topounit(p) - lbl_rsc_h2o(p) = getlblcef(forc_rho(t),t_veg(p))*uaf(p)/(uaf(p)**2._r8+1.e-10_r8) !laminar boundary resistance for h2o over leaf, should I make this consistent for latent heat calculation? + !laminar boundary resistance for h2o over leaf, should I make this consistent for latent heat calculation? + lbl_rsc_h2o(p) = getlblcef(forc_rho(t),t_veg(p))*uaf(f)/(uaf(f)**2._r8+1.e-10_r8) enddo ! Test for convergence - iter_final = itlef itlef = itlef+1 if (itlef > itmin) then + fnold = 0 + num_unconverged = 0 + !$acc parallel loop independent gang vector default(present) private(p) present(det(1:fn), dele(1:fn)) & + !$acc copy(num_unconverged) reduction(+:num_unconverged) do f = 1, fn + if(converged(f)) cycle p = filterp(f) - dele(p) = abs(efe(p)-efeb(p)) - efeb(p) = efe(p) - det(p) = max(del(p),del2(p)) num_iter(p) = real(itlef,r8) - end do - fnold = fn - fn = 0 - do f = 1, fnold - p = filterp(f) - if (.not. (det(p) < dtmin .and. dele(p) < dlemin) .or. & - (implicit_stress .and. abs(tau_diff(p)) >= dtaumin)) then - fn = fn + 1 - filterp(fn) = p - end if + dele(f) = abs(efe(f) - efeb(f)) + efeb(f) = efe(f) + det(f) = max(del(f),del2(f)) + if((det(f) < dtmin .and. dele(f) < dlemin)) then + converged(f) = 1 + else + num_unconverged = num_unconverged + 1 + end if end do end if - end do ITERATION ! End stability iteration - call t_stopf('can_iter') - fn = fnorig - filterp(1:fn) = fporig(1:fn) - - do f = 1, fn - p = filterp(f) + call t_stopf('can_iter') + + !$acc parallel loop independent gang vector default(present) + do f = 1, num_nolu_vegp + p = filter_nolu_vegp(f) c = veg_pp%column(p) t = veg_pp%topounit(p) g = veg_pp%gridcell(p) @@ -1221,50 +1214,45 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & +(1._r8-frac_sno(c)-frac_h2osfc(c))*t_soisno(c,1)**4 & +frac_h2osfc(c)*t_h2osfc(c)**4) - err(p) = sabv(p) + air(p) + bir(p)*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p)) & - !+ cir(p)*t_grnd(c)**4 - eflx_sh_veg(p) - hvap*qflx_evap_veg(p) - + cir(p)*lw_grnd - eflx_sh_veg(p) - hvap*qflx_evap_veg(p) + err(f) = sabv(p) + air(f) + bir(f)*tlbef(f)**3*(tlbef(f) + 4._r8*dt_veg(f)) & + + cir(f)*lw_grnd - eflx_sh_veg(p) - hvap*qflx_evap_veg(p) ! Fluxes from ground to canopy space - delt = wtal(p)*t_grnd(c)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) + delt = wtal(f)*t_grnd(c)-wtl0(f)*t_veg(p)-wta0(f)*thm(p) taux(p) = -forc_rho(t)*forc_u(t)/ram1(p) tauy(p) = -forc_rho(t)*forc_v(t)/ram1(p) - if (implicit_stress) then - taux(p) = taux(p) * (wind_speed_adj(p) / wind_speed0(p)) - tauy(p) = tauy(p) * (wind_speed_adj(p) / wind_speed0(p)) - end if - eflx_sh_grnd(p) = cpair*forc_rho(t)*wtg(p)*delt + eflx_sh_grnd(p) = cpair*forc_rho(t)*wtg(f)*delt ! compute individual sensible heat fluxes - delt_snow = wtal(p)*t_soisno(c,snl(c)+1)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) - eflx_sh_snow(p) = cpair*forc_rho(t)*wtg(p)*delt_snow + delt_snow = wtal(f)*t_soisno(c,snl(c)+1)-wtl0(f)*t_veg(p)-wta0(f)*thm(p) + eflx_sh_snow(p) = cpair*forc_rho(t)*wtg(f)*delt_snow - delt_soil = wtal(p)*t_soisno(c,1)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) - eflx_sh_soil(p) = cpair*forc_rho(t)*wtg(p)*delt_soil + delt_soil = wtal(f)*t_soisno(c,1)-wtl0(f)*t_veg(p)-wta0(f)*thm(p) + eflx_sh_soil(p) = cpair*forc_rho(t)*wtg(f)*delt_soil - delt_h2osfc = wtal(p)*t_h2osfc(c)-wtl0(p)*t_veg(p)-wta0(p)*thm(p) - eflx_sh_h2osfc(p) = cpair*forc_rho(t)*wtg(p)*delt_h2osfc - qflx_evap_soi(p) = forc_rho(t)*wtgq(p)*delq(p) + delt_h2osfc = wtal(f)*t_h2osfc(c)-wtl0(f)*t_veg(p)-wta0(f)*thm(p) + eflx_sh_h2osfc(p) = cpair*forc_rho(t)*wtg(f)*delt_h2osfc + qflx_evap_soi(p) = forc_rho(t)*wtgq(f)*delq(f) ! compute individual latent heat fluxes - delq_snow = wtalq(p)*qg_snow(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(t) - qflx_ev_snow(p) = forc_rho(t)*wtgq(p)*delq_snow + delq_snow = wtalq(f)*qg_snow(c)-wtlq0(f)*qsatl(f)-wtaq0(f)*forc_q(t) + qflx_ev_snow(p) = forc_rho(t)*wtgq(f)*delq_snow - delq_soil = wtalq(p)*qg_soil(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(t) - qflx_ev_soil(p) = forc_rho(t)*wtgq(p)*delq_soil + delq_soil = wtalq(f)*qg_soil(c)-wtlq0(f)*qsatl(f)-wtaq0(f)*forc_q(t) + qflx_ev_soil(p) = forc_rho(t)*wtgq(f)*delq_soil - delq_h2osfc = wtalq(p)*qg_h2osfc(c)-wtlq0(p)*qsatl(p)-wtaq0(p)*forc_q(t) - qflx_ev_h2osfc(p) = forc_rho(t)*wtgq(p)*delq_h2osfc + delq_h2osfc = wtalq(f)*qg_h2osfc(c)-wtlq0(f)*qsatl(f)-wtaq0(f)*forc_q(t) + qflx_ev_h2osfc(p) = forc_rho(t)*wtgq(f)*delq_h2osfc ! 2 m height air temperature - t_ref2m(p) = thm(p) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p)) + t_ref2m(p) = thm(p) + temp1(f)*dth(f)*(1._r8/temp12m(f) - 1._r8/temp1(f)) t_ref2m_r(p) = t_ref2m(p) ! 2 m height specific humidity - q_ref2m(p) = forc_q(t) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p)) + q_ref2m(p) = forc_q(t) + temp2(f)*dqh(f)*(1._r8/temp22m(f) - 1._r8/temp2(f)) ! 2 m height relative humidity @@ -1272,36 +1260,36 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & rh_ref2m(p) = min(100._r8, q_ref2m(p) / qsat_ref2m * 100._r8) rh_ref2m_r(p) = rh_ref2m(p) - ! Downward longwave radiation below the canopy if (use_finetop_rad) then slope_rad = slope_deg(g) * deg2rad + + ! Downward longwave radiation below the canopy dlrad(p) = (1._r8-emv(p))*emg(c)*forc_lwrad(t) + & - emv(p)*emg(c)*sb*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p))/cos(slope_rad) + emv(p)*emg(c)*sb*tlbef(p)**3*(tlbef(f) + 4._r8*dt_veg(f))/cos(slope_rad) + + ! Upward longwave radiation above the canopy + ulrad(p) = ((1._r8-emg(c))*(1._r8-emv(p))*(1._r8-emv(p))*forc_lwrad(t) & + + emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(f)**3*(tlbef(f) + & + 4._r8*dt_veg(f))/cos(slope_rad) + emg(c)*(1._r8-emv(p))*sb*lw_grnd/cos(slope_rad)) else dlrad(p) = (1._r8-emv(p))*emg(c)*forc_lwrad(t) + & emv(p)*emg(c)*sb*tlbef(p)**3*(tlbef(p) + 4._r8*dt_veg(p)) - endif - ! Upward longwave radiation above the canopy - if (use_finetop_rad) then - slope_rad = slope_deg(g) * deg2rad - ulrad(p) = ((1._r8-emg(c))*(1._r8-emv(p))*(1._r8-emv(p))*forc_lwrad(t) & - + emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(p)**3*(tlbef(p) + & - 4._r8*dt_veg(p))/cos(slope_rad) + emg(c)*(1._r8-emv(p))*sb*lw_grnd/cos(slope_rad)) - else + ulrad(p) = ((1._r8-emg(c))*(1._r8-emv(p))*(1._r8-emv(p))*forc_lwrad(t) & - + emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(p)**3*(tlbef(p) + & - 4._r8*dt_veg(p)) + emg(c)*(1._r8-emv(p))*sb*lw_grnd) + + emv(p)*(1._r8+(1._r8-emg(c))*(1._r8-emv(p)))*sb*tlbef(f)**3*(tlbef(f) + & + 4._r8*dt_veg(f)) + emg(c)*(1._r8-emv(p))*sb*lw_grnd) endif + ! Derivative of soil energy flux with respect to soil temperature - cgrnds(p) = cgrnds(p) + cpair*forc_rho(t)*wtg(p)*wtal(p) - cgrndl(p) = cgrndl(p) + forc_rho(t)*wtgq(p)*wtalq(p)*dqgdT(c) + cgrnds(p) = cgrnds(p) + cpair*forc_rho(t)*wtg(f)*wtal(f) + cgrndl(p) = cgrndl(p) + forc_rho(t)*wtgq(f)*wtalq(f)*dqgdT(c) cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c) ! Update dew accumulation (kg/m2) - h2ocan(p) = max(0._r8,h2ocan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime) + h2ocan(p) = max(0._r8,h2ocan(p)+(qflx_tran_veg(p)-qflx_evap_veg(p))*dtime_mod) ! Check for convergence of stress. if (implicit_stress .and. abs(tau_diff(p)) > dtaumin) then @@ -1314,42 +1302,59 @@ subroutine CanopyFluxes(bounds, num_nolakeurbanp, filter_nolakeurbanp, & end if end do + ! variables for history fields + rah_above(p) = rah(p,above_canopy) + raw_above(p) = raw(p,above_canopy) + rah_below(p) = rah(p,below_canopy) + raw_below(p) = raw(p,below_canopy) + vpd(p) = max((svpts(p) - eah(p)), vpd_min) * pa_to_kpa ! kPa if ( use_fates ) then -#ifndef _OPENACC call alm_fates%wrap_accumulatefluxes(bounds,fn,filterp(1:fn)) call alm_fates%wrap_hydraulics_drive(bounds,fn,filterp(1:fn),soilstate_vars, & - solarabs_vars,energyflux_vars) -#endif + solarabs_vars,energyflux_vars) else ! Determine total photosynthesis - call PhotosynthesisTotal(fn, filterp, & - atm2lnd_vars, cnstate_vars, canopystate_vars, photosyns_vars) - + call PhotosynthesisTotal(num_nolu_vegp, filter_nolu_vegp, & + cnstate_vars, canopystate_vars, photosyns_vars) ! Filter out patches which have small energy balance errors; report others - - fnold = fn + ! NOTE: filter out patches for what? This is the end of the subroutine. + fnold = num_nolu_vegp fn = 0 + !$acc parallel loop independent gang vector default(present) do f = 1, fnold p = filterp(f) - if (abs(err(p)) > 0.1_r8) then + if (abs(err(f)) > 0.1_r8) then fn = fn + 1 filterp(fn) = p + write(iulog,*), 'energy balance in canopy ',p,', err=',err(f) + write(iulog,*) "sabv :", sabv(p) + write(iulog,*) "air :",air(p) + write(iulog,*) "bir :" ,bir(p) + write(iulog,*) "cir :" ,cir(p) + write(iulog,*) "tlbef :",tlbef(p) + write(iulog,*) "dt_veg:",dt_veg(p) + write(iulog,*) "eflx_sh_veg:",eflx_sh_veg(p) + write(iulog,*) "qflx_evap_veg:",qflx_evap_veg(p) end if end do - do f = 1, fn - p = filterp(f) - write(iulog,*) 'energy balance in canopy ',p,', err=',err(p) - end do - end if - + !$acc exit data delete(del(:), efeb(:), wtlq0(:),wtalq(:), & + !$acc wtgq(:), wtaq0(:), obuold(:),dayl_factor(:) , & + !$acc check_for_irrig(:), filterp(:),zldis(:), & + !$acc air(:),bir(:), cir(:), co2(:),o2(:),& + !$acc nmozsgn(:), taf(:),qaf(:), ur(:),dth(:),dqh(:),delq(:), & + !$acc dthv(:), obu(:),el(:),qsatl(:),qsatldT(:), & + !$acc temp1(:), temp2(:),temp12m(:),& + !$acc temp22m(:),ustar(:), um(:),rah(:,:),raw(:,:), uaf(:),rb(:), & + !$acc tlbef(:), del(:),del2(:),svpts(:),eah(:),wta0(:), err(:), dt_veg(:) ,wtg(:), & + !$acc wtal(:), wtl0(:), efe(:), det(:), dele(:), fm(:), converged(:) ) + !$acc exit data delete(time,irrig_nsteps_per_day, itlef) end associate - end subroutine CanopyFluxes end module CanopyFluxesMod diff --git a/components/elm/src/biogeophys/CanopyHydrologyMod.F90 b/components/elm/src/biogeophys/CanopyHydrologyMod.F90 index 3d2751f88cd9..dd6008abb538 100644 --- a/components/elm/src/biogeophys/CanopyHydrologyMod.F90 +++ b/components/elm/src/biogeophys/CanopyHydrologyMod.F90 @@ -29,7 +29,8 @@ module CanopyHydrologyMod use elm_varcon , only : snw_rds_min use pftvarcon , only : irrigated use GridcellType , only : grc_pp - use timeinfoMod , only : dtime_mod + use timeinfoMod, only : dtime_mod + use domainMod ,only : ldomain_gpu ! ! !PUBLIC TYPES: implicit none @@ -93,6 +94,7 @@ subroutine CanopyHydrology_readnl( NLFilename ) end if ! Broadcast namelist variables read in call shr_mpi_bcast(oldfflag, mpicom) + !$acc update device(oldfflag) end subroutine CanopyHydrology_readnl @@ -362,8 +364,8 @@ subroutine CanopyHydrology(bounds, & end if ! Urban sunwall and shadewall have no intercepted precipitation else - qflx_prec_grnd_snow(p) = 0. - qflx_prec_grnd_rain(p) = 0. + qflx_prec_grnd_snow = 0._r8 + qflx_prec_grnd_rain = 0._r8 qflx_dirct_rain(p) = 0._r8 qflx_leafdrip(p) = 0._r8 end if @@ -410,14 +412,14 @@ subroutine CanopyHydrology(bounds, & endif endif qflx_real_irrig(p) = qflx_surf_irrig(p) + qflx_grnd_irrig(p) ! actual irrigation, including groundwater irrigation - qflx_prec_grnd_rain(p) = qflx_prec_grnd_rain(p) + qflx_real_irrig(p) + qflx_prec_grnd_rain = qflx_prec_grnd_rain + qflx_real_irrig(p) end if end if else ! one way coupling qflx_surf_irrig(p) = f_surf(g,tpu_ind)*qflx_irrig(p) qflx_grnd_irrig(p) = f_grd(g,tpu_ind)*qflx_irrig(p) qflx_real_irrig(p) = qflx_surf_irrig(p) + qflx_grnd_irrig(p) - qflx_prec_grnd_rain(p) = qflx_prec_grnd_rain(p) + qflx_real_irrig(p) + qflx_prec_grnd_rain = qflx_prec_grnd_rain + qflx_real_irrig(p) qflx_over_supply(p) = 0._r8 qflx_supply(p) = 0._r8 !no water supplied by MOSART end if diff --git a/components/elm/src/biogeophys/CanopyTemperatureMod.F90 b/components/elm/src/biogeophys/CanopyTemperatureMod.F90 index 808d69af92c2..52df8514969c 100644 --- a/components/elm/src/biogeophys/CanopyTemperatureMod.F90 +++ b/components/elm/src/biogeophys/CanopyTemperatureMod.F90 @@ -68,7 +68,6 @@ subroutine CanopyTemperature(bounds, & ! Ha = Hf + Hg and Ea = Ef + Eg ! ! !USES: - !$acc routine seq use QSatMod , only : QSat use elm_varcon , only : denh2o, denice, roverg, hvap, hsub, zlnd, zsno, tfrz, spval use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall @@ -95,6 +94,7 @@ subroutine CanopyTemperature(bounds, & integer :: j ! soil/snow level index integer :: fp ! lake filter pft index integer :: fc ! lake filter column index + integer :: begp, endp ! patch bounds real(r8) :: qred ! soil surface relative humidity real(r8) :: avmuir ! ir inverse optical depth per unit leaf area real(r8) :: eg ! water vapor pressure at temperature T [pa] @@ -110,7 +110,6 @@ subroutine CanopyTemperature(bounds, & real(r8) :: eff_porosity ! effective porosity in layer real(r8) :: vol_ice ! partial volume of ice lens in layer real(r8) :: vol_liq ! partial volume of liquid water in layer - real(r8) :: fh2o_eff(bounds%begc:bounds%endc) ! effective surface water fraction (i.e. seen by atm) real(r8) :: slope_rad, deg2rad !------------------------------------------------------------------------------ @@ -204,6 +203,9 @@ subroutine CanopyTemperature(bounds, & ) deg2rad = SHR_CONST_PI/180._r8 + begp = bounds%begp + endp = bounds%endp + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1, nlevgrnd do fc = 1,num_nolakec c = filter_nolakec(fc) @@ -220,7 +222,8 @@ subroutine CanopyTemperature(bounds, & ! calculate moisture stress/resistance for soil evaporation call calc_soilevap_stress(bounds, num_nolakec, filter_nolakec, soilstate_vars) - + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -263,6 +266,7 @@ subroutine CanopyTemperature(bounds, & else if (col_pp%itype(c) == icol_road_perv) then ! Pervious road depends on water in total soil column nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed if (t_soisno(c,j) >= tfrz) then vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) @@ -395,12 +399,10 @@ subroutine CanopyTemperature(bounds, & ! of its dynamics call. If and when crops are ! enabled simultaneously with FATES, we will ! have to apply a filter here. -#ifndef _OPENACC if(use_fates) then call alm_fates%TransferZ0mDisp(bounds,frictionvel_vars,canopystate_vars) end if -#endif - + !$acc parallel loop independent gang vector default(present) do fp = 1,num_nolakep p = filter_nolakep(fp) if( .not.(veg_pp%is_fates(p))) then @@ -411,6 +413,7 @@ subroutine CanopyTemperature(bounds, & ! Initialization + !$acc parallel loop independent gang vector default(present) do fp = 1,num_nolakep p = filter_nolakep(fp) g = veg_pp%gridcell(p) @@ -459,7 +462,8 @@ subroutine CanopyTemperature(bounds, & ! Make forcing height a pft-level quantity that is the atmospheric forcing ! height plus each pft's z0m+displa - do p = bounds%begp,bounds%endp + !$acc parallel loop independent gang vector default(present) + do p = begp,endp if (veg_pp%active(p)) then g = veg_pp%gridcell(p) t = veg_pp%topounit(p) @@ -493,6 +497,7 @@ subroutine CanopyTemperature(bounds, & end if end do + !$acc parallel loop independent gang vector default(present) do fp = 1,num_nolakep p = filter_nolakep(fp) c = veg_pp%column(p) diff --git a/components/elm/src/biogeophys/DaylengthMod.F90 b/components/elm/src/biogeophys/DaylengthMod.F90 index ba6d88ae2f1a..93aeb274abf9 100644 --- a/components/elm/src/biogeophys/DaylengthMod.F90 +++ b/components/elm/src/biogeophys/DaylengthMod.F90 @@ -18,7 +18,10 @@ module DaylengthMod public :: UpdateDaylength ! update daylength for all grid cells ! ! !PRIVATE DATA MEMBERS: - logical :: first_step ! is this the first step since initialization? + logical, public :: first_step = .true. ! is this the first step since initialization? + + !$acc declare create(first_step) + ! !----------------------------------------------------------------------- diff --git a/components/elm/src/biogeophys/FrictionVelocityMod.F90 b/components/elm/src/biogeophys/FrictionVelocityMod.F90 index 9d2883ffc81c..4c3c67f073d4 100644 --- a/components/elm/src/biogeophys/FrictionVelocityMod.F90 +++ b/components/elm/src/biogeophys/FrictionVelocityMod.F90 @@ -23,22 +23,27 @@ module FrictionVelocityMod logical, public :: force_land_gustiness = .false. ! ! !PUBLIC MEMBER FUNCTIONS: - public :: FrictionVelocity ! Calculate friction velocity - public :: MoninObukIni ! Initialization of the Obukhov length scale + public :: MoninObukIni ! Initialization of the Monin-Obukhov length + interface FrictionVelocity ! Calculate friction velocity + module procedure :: FrictionVelocity_noloop ! called inside parallel region + module procedure :: FrictionVelocity_loops ! internal parallelism + end interface FrictionVelocity + + public :: FrictionVelocity ! ! !PRIVATE MEMBER FUNCTIONS: private :: StabilityFunc1 ! Stability function for rib < 0. private :: StabilityFunc2 ! Stability function for rib < 0. !------------------------------------------------------------------------------ - - contains !------------------------------------------------------------------------------ - subroutine FrictionVelocity(lbn, ubn, fn, filtern, & + subroutine FrictionVelocity_noloop( & displa, z0m, z0h, z0q, & obu, iter, ur, um, ugust, ustar, & - temp1, temp2, temp12m, temp22m, fm,frictionvel_vars,landunit_index) + temp1, temp2, temp12m, temp22m, fm, & + forc_hgt_u_patch , forc_hgt_t_patch, forc_hgt_q_patch, & + vds, u10, u10_elm, u10_with_gusts_elm, va, fv) !$acc routine seq ! !DESCRIPTION: ! Calculation of the friction velocity, relation for potential @@ -50,40 +55,38 @@ subroutine FrictionVelocity(lbn, ubn, fn, filtern, & ! ! !USES: use elm_varcon, only : vkc - - implicit none ! ! !ARGUMENTS: - integer , intent(in) :: lbn, ubn ! pft/landunit array bounds - integer , intent(in) :: fn ! number of filtered pft/landunit elements - integer , intent(in) :: filtern(fn) ! pft/landunit filter - real(r8) , intent(in) :: displa ( lbn: ) ! displacement height (m) [lbn:ubn] - real(r8) , intent(in) :: z0m ( lbn: ) ! roughness length over vegetation, momentum [m] [lbn:ubn] - real(r8) , intent(in) :: z0h ( lbn: ) ! roughness length over vegetation, sensible heat [m] [lbn:ubn] - real(r8) , intent(in) :: z0q ( lbn: ) ! roughness length over vegetation, latent heat [m] [lbn:ubn] - real(r8) , intent(in) :: obu ( lbn: ) ! Obukhov length scale (m) [lbn:ubn] - integer , intent(in) :: iter ! iteration number - real(r8) , intent(in) :: ur ( lbn: ) ! wind speed at reference height [m/s] [lbn:ubn] - real(r8) , intent(in) :: um ( lbn: ) ! wind speed including the stablity effect [m/s] [lbn:ubn] - real(r8) , intent(in) :: ugust ( lbn: ) ! Gustiness wind speed [m/s] [lbn:ubn] - real(r8) , intent(out) :: ustar ( lbn: ) ! friction velocity [m/s] [lbn:ubn] - real(r8) , intent(out) :: temp1 ( lbn: ) ! relation for potential temperature profile [lbn:ubn] - real(r8) , intent(out) :: temp12m ( lbn: ) ! relation for potential temperature profile applied at 2-m [lbn:ubn] - real(r8) , intent(out) :: temp2 ( lbn: ) ! relation for specific humidity profile [lbn:ubn] - real(r8) , intent(out) :: temp22m ( lbn: ) ! relation for specific humidity profile applied at 2-m [lbn:ubn] - real(r8) , intent(inout) :: fm ( lbn: ) ! diagnose 10m wind (DUST only) [lbn:ubn] - type(frictionvel_type) , intent(inout) :: frictionvel_vars - logical , intent(in), optional :: landunit_index ! optional argument that defines landunit or pft level + real(r8) , intent(in) :: displa ! displacement height (m) [lbn:ubn] + real(r8) , intent(in) :: z0m ! roughness length over vegetation, momentum [m] [lbn:ubn] + real(r8) , intent(in) :: z0h ! roughness length over vegetation, sensible heat [m] [lbn:ubn] + real(r8) , intent(in) :: z0q ! roughness length over vegetation, latent heat [m] [lbn:ubn] + real(r8) , intent(in) :: obu ! monin-obukhov length (m) [lbn:ubn] + integer , intent(in) :: iter ! iteration number + real(r8) , intent(in) :: ur ! wind speed at reference height [m/s] [lbn:ubn] + real(r8) , intent(in) :: um ! wind speed including the stablity effect [m/s] [lbn:ubn] + real(r8) , intent(in) :: ugust + real(r8) , intent(out) :: ustar ! friction velocity [m/s] [lbn:ubn] + real(r8) , intent(out) :: temp1 ! relation for potential temperature profile [lbn:ubn] + real(r8) , intent(out) :: temp12m ! relation for potential temperature profile applied at 2-m [lbn:ubn] + real(r8) , intent(out) :: temp2 ! relation for specific humidity profile [lbn:ubn] + real(r8) , intent(out) :: temp22m ! relation for specific humidity profile applied at 2-m [lbn:ubn] + real(r8) , intent(inout) :: fm ! diagnose 10m wind (DUST only) [lbn:ubn] + real(r8) , intent(in) :: forc_hgt_u_patch ! observational height of wind at pft level [m] + real(r8) , intent(in) :: forc_hgt_t_patch ! observational height of temperature at pft level [m] + real(r8) , intent(in) :: forc_hgt_q_patch ! observational height of specific humidity at pft level [m] + real(r8) , intent(inout) :: vds ! dry deposition velocity term (m/s) (for SO4 NH4NO3) + real(r8) , intent(inout) :: u10 ! 10-m wind (m/s) (for dust model) + real(r8) , intent(inout) :: u10_elm ! 10-m wind (m/s) + real(r8) , intent(inout) :: u10_with_gusts_elm + real(r8) , intent(inout) :: va ! atmospheric wind speed plus convective velocity (m/s) + real(r8) , intent(inout) :: fv ! friction velocity (m/s) (for dust model) + ! ! !LOCAL VARIABLES: real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile) real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile) - integer :: f ! pft/landunit filter index - integer :: n ! pft/landunit index - integer :: g ! gridcell index - integer :: pp ! pfti,pftf index - integer :: pfti, pftf real(r8) :: zldis ! reference height "minus" zero displacement heght [m] real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory real(r8) :: tmp1,tmp2,tmp3,tmp4 ! Used to diagnose the 10 meter wind @@ -92,308 +95,563 @@ subroutine FrictionVelocity(lbn, ubn, fn, filtern, & real(r8) :: zeta10 ! Used to diagnose the 10 meter wind real(r8) :: vds_tmp ! Temporary for dry deposition velocity !------------------------------------------------------------------------------ - associate( & - forc_hgt_u_patch => frictionvel_vars%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at pft level [m] - forc_hgt_t_patch => frictionvel_vars%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] - forc_hgt_q_patch => frictionvel_vars%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] - vds => frictionvel_vars%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) - u10 => frictionvel_vars%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) - u10_elm => frictionvel_vars%u10_elm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) - u10_with_gusts_elm=>frictionvel_vars%u10_with_gusts_elm_patch, & ! Output: [real(r8) (:) ] 10-m wind with gusts(m/s) - va => frictionvel_vars%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) - fv => frictionvel_vars%fv_patch & ! Output: [real(r8) (:) ] friction velocity (m/s) (for dust model) - ) - - ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. - - do f = 1, fn - n = filtern(f) - - if (present(landunit_index)) then - g = lun_pp%gridcell(n) - pfti = lun_pp%pfti(n) - pftf = lun_pp%pftf(n) - else - g = veg_pp%gridcell(n) - end if - - ! Wind profile - - if (present(landunit_index)) then - zldis = forc_hgt_u_patch(pfti)-displa(n) - else - zldis = forc_hgt_u_patch(n)-displa(n) - end if - - zeta = zldis/obu(n) - if (zeta < -zetam) then - ustar(n) = vkc*um(n)/(log(-zetam*obu(n)/z0m(n))& - - StabilityFunc1(-zetam) & - + StabilityFunc1(z0m(n)/obu(n)) & - + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) - else if (zeta < 0._r8) then - ustar(n) = vkc*um(n)/(log(zldis/z0m(n))& - - StabilityFunc1(zeta)& - + StabilityFunc1(z0m(n)/obu(n))) - else if (zeta <= 1._r8) then - ustar(n) = vkc*um(n)/(log(zldis/z0m(n)) + 5._r8*zeta -5._r8*z0m(n)/obu(n)) - else - ustar(n) = vkc*um(n)/(log(obu(n)/z0m(n))+5._r8-5._r8*z0m(n)/obu(n) & - +(5._r8*log(zeta)+zeta-1._r8)) - end if - - if (zeta < 0._r8) then - vds_tmp = 2.e-3_r8*ustar(n) * ( 1._r8 + (300._r8/(-obu(n)))**0.666_r8) - else - vds_tmp = 2.e-3_r8*ustar(n) - endif - - if (present(landunit_index)) then - do pp = pfti,pftf - vds(pp) = vds_tmp - end do - else - vds(n) = vds_tmp - end if - - ! Calculate a 10-m wind (10m + z0m + d) - ! For now, this will not be the same as the 10-m wind calculated for the dust - ! model because the CLM stability functions are used here, not the LSM stability - ! functions used in the dust model. We will eventually change the dust model to be - ! consistent with the following formulation. - ! Note that the 10-m wind calculated this way could actually be larger than the - ! atmospheric forcing wind because 1) this includes the convective velocity, 2) - ! this includes the 1 m/s minimum wind threshold - - ! If forcing height is less than or equal to 10m, then set 10-m wind to um - if (present(landunit_index)) then - do pp = pfti,pftf - if (zldis-z0m(n) <= 10._r8) then - u10_with_gusts_elm(pp) = um(n) - else - if (zeta < -zetam) then - u10_with_gusts_elm(pp) = um(n) - ( ustar(n)/vkc*(log(-zetam*obu(n)/(10._r8+z0m(n))) & - - StabilityFunc1(-zetam) & - + StabilityFunc1((10._r8+z0m(n))/obu(n)) & - + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) ) - else if (zeta < 0._r8) then - u10_with_gusts_elm(pp) = um(n) - ( ustar(n)/vkc*(log(zldis/(10._r8+z0m(n))) & - - StabilityFunc1(zeta) & - + StabilityFunc1((10._r8+z0m(n))/obu(n))) ) - else if (zeta <= 1._r8) then - u10_with_gusts_elm(pp) = um(n) - ( ustar(n)/vkc*(log(zldis/(10._r8+z0m(n))) & - + 5._r8*zeta - 5._r8*(10._r8+z0m(n))/obu(n)) ) - else - u10_with_gusts_elm(pp) = um(n) - ( ustar(n)/vkc*(log(obu(n)/(10._r8+z0m(n))) & - + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) ) - - end if - end if - va(pp) = um(n) - ! Estimate u10 with effects of gustiness removed. - u10_elm(pp) = u10_with_gusts_elm(pp) * sqrt(max(0., um(n)**2 - ugust(n)**2)) / um(n) - end do - else - if (zldis-z0m(n) <= 10._r8) then - u10_with_gusts_elm(n) = um(n) - else - if (zeta < -zetam) then - u10_with_gusts_elm(n) = um(n) - ( ustar(n)/vkc*(log(-zetam*obu(n)/(10._r8+z0m(n))) & - - StabilityFunc1(-zetam) & - + StabilityFunc1((10._r8+z0m(n))/obu(n)) & - + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) ) - else if (zeta < 0._r8) then - u10_with_gusts_elm(n) = um(n) - ( ustar(n)/vkc*(log(zldis/(10._r8+z0m(n))) & - - StabilityFunc1(zeta) & - + StabilityFunc1((10._r8+z0m(n))/obu(n))) ) - else if (zeta <= 1._r8) then - u10_with_gusts_elm(n) = um(n) - ( ustar(n)/vkc*(log(zldis/(10._r8+z0m(n))) & - + 5._r8*zeta - 5._r8*(10._r8+z0m(n))/obu(n)) ) - else - u10_with_gusts_elm(n) = um(n) - ( ustar(n)/vkc*(log(obu(n)/(10._r8+z0m(n))) & - + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) ) - end if - end if - va(n) = um(n) - ! Estimate u10 with effects of gustiness removed. - u10_elm(n) = u10_with_gusts_elm(n) * sqrt(max(0., um(n)**2 - ugust(n)**2)) / um(n) - end if - - !===================! - !Temperature Profile! - !===================! - if (present(landunit_index)) then - zldis = forc_hgt_t_patch(pfti)-displa(n) - else - zldis = forc_hgt_t_patch(n)-displa(n) - end if - zeta = zldis/obu(n) - if (zeta < -zetat) then - temp1(n) = vkc/(log(-zetat*obu(n)/z0h(n))& - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0h(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) - else if (zeta < 0._r8) then - temp1(n) = vkc/(log(zldis/z0h(n)) & - - StabilityFunc2(zeta) & - + StabilityFunc2(z0h(n)/obu(n))) - else if (zeta <= 1._r8) then - temp1(n) = vkc/(log(zldis/z0h(n)) + 5._r8*zeta - 5._r8*z0h(n)/obu(n)) - else - temp1(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) - end if - !=================! - !Humidity Profile ! - !=================! - if (present(landunit_index)) then - if (forc_hgt_q_patch(pfti) == forc_hgt_t_patch(pfti) .and. z0q(n) == z0h(n)) then - temp2(n) = temp1(n) - else - zldis = forc_hgt_q_patch(pfti)-displa(n) - zeta = zldis/obu(n) - if (zeta < -zetat) then - temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) & - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) - else if (zeta < 0._r8) then - temp2(n) = vkc/(log(zldis/z0q(n)) & - - StabilityFunc2(zeta) & - + StabilityFunc2(z0q(n)/obu(n))) - else if (zeta <= 1._r8) then - temp2(n) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(n)) - else - temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) - end if - end if - else - if (forc_hgt_q_patch(n) == forc_hgt_t_patch(n) .and. z0q(n) == z0h(n)) then - temp2(n) = temp1(n) - else - zldis = forc_hgt_q_patch(n)-displa(n) - zeta = zldis/obu(n) - if (zeta < -zetat) then - temp2(n) = vkc/(log(-zetat*obu(n)/z0q(n)) & - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) - else if (zeta < 0._r8) then - temp2(n) = vkc/(log(zldis/z0q(n)) & - - StabilityFunc2(zeta) & - + StabilityFunc2(z0q(n)/obu(n))) - else if (zeta <= 1._r8) then - temp2(n) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(n)) - else - temp2(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) - end if - endif - endif - - ! Temperature profile applied at 2-m - - zldis = 2.0_r8 + z0h(n) - zeta = zldis/obu(n) - if (zeta < -zetat) then - temp12m(n) = vkc/(log(-zetat*obu(n)/z0h(n))& - - StabilityFunc2(-zetat) & - + StabilityFunc2(z0h(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) - else if (zeta < 0._r8) then - temp12m(n) = vkc/(log(zldis/z0h(n)) & - - StabilityFunc2(zeta) & - + StabilityFunc2(z0h(n)/obu(n))) - else if (zeta <= 1._r8) then - temp12m(n) = vkc/(log(zldis/z0h(n)) + 5._r8*zeta - 5._r8*z0h(n)/obu(n)) - else - temp12m(n) = vkc/(log(obu(n)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) - end if - - ! Humidity profile applied at 2-m - - if (z0q(n) == z0h(n)) then - temp22m(n) = temp12m(n) - else - zldis = 2.0_r8 + z0q(n) - zeta = zldis/obu(n) - if (zeta < -zetat) then - temp22m(n) = vkc/(log(-zetat*obu(n)/z0q(n)) - & - StabilityFunc2(-zetat) + StabilityFunc2(z0q(n)/obu(n)) & - + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) - else if (zeta < 0._r8) then - temp22m(n) = vkc/(log(zldis/z0q(n)) - & - StabilityFunc2(zeta)+StabilityFunc2(z0q(n)/obu(n))) - else if (zeta <= 1._r8) then - temp22m(n) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(n)) - else - temp22m(n) = vkc/(log(obu(n)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(n) & - + (5._r8*log(zeta)+zeta-1._r8)) - end if - end if - - ! diagnose 10-m wind for dust model (dstmbl.F) - ! Notes from C. Zender's dst.F: - ! According to Bon96 p. 62, the displacement height d (here displa) is - ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). - ! Therefore d <= 0.034*z1 and may safely be neglected. - ! Code from LSM routine SurfaceTemperature was used to obtain u10 - - - if (present(landunit_index)) then - zldis = forc_hgt_u_patch(pfti)-displa(n) - else - zldis = forc_hgt_u_patch(n)-displa(n) - end if - - zeta = zldis/obu(n) - if (min(zeta, 1._r8) < 0._r8) then - tmp1 = (1._r8 - 16._r8*min(zeta,1._r8))**0.25_r8 - tmp2 = log((1._r8+tmp1*tmp1)/2._r8) - tmp3 = log((1._r8+tmp1)/2._r8) - fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 - else - fmnew = -5._r8*min(zeta,1._r8) - endif - if (iter == 1) then - fm(n) = fmnew - else - fm(n) = 0.5_r8 * (fm(n)+fmnew) - end if - zeta10 = min(10._r8/obu(n), 1._r8) - if (zeta == 0._r8) zeta10 = 0._r8 - if (zeta10 < 0._r8) then - tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 - tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) - tmp3 = log((1.0_r8 + tmp1)/2.0_r8) - fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 - else ! not stable - fm10 = -5.0_r8 * zeta10 - end if - - if (present(landunit_index)) then - tmp4 = log( max( 1.0_8, forc_hgt_u_patch(pfti) / 10._r8) ) - else - tmp4 = log( max( 1.0_8, forc_hgt_u_patch(n) / 10._r8) ) - end if - if (present(landunit_index)) then - do pp = pfti,pftf - u10(pp) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10) - fv(pp) = ustar(n) - end do - else - u10(n) = ur(n) - ustar(n)/vkc * (tmp4 - fm(n) + fm10) - fv(n) = ustar(n) - end if - end do !! do loop of fn - - end associate - - end subroutine FrictionVelocity + ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + + ! Wind profile + zldis = forc_hgt_u_patch-displa + + zeta = zldis/obu + if (zeta < -zetam) then + ustar = vkc*um/(log(-zetam*obu/z0m)& + - StabilityFunc1(-zetam) & + + StabilityFunc1(z0m/obu) & + + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) + else if (zeta < 0._r8) then + ustar = vkc*um/(log(zldis/z0m)& + - StabilityFunc1(zeta)& + + StabilityFunc1(z0m/obu)) + else if (zeta <= 1._r8) then + ustar = vkc*um/(log(zldis/z0m) + 5._r8*zeta -5._r8*z0m/obu) + else + ustar = vkc*um/(log(obu/z0m)+5._r8-5._r8*z0m/obu & + +(5._r8*log(zeta)+zeta-1._r8)) + end if + + if (zeta < 0._r8) then + vds_tmp = 2.e-3_r8*ustar * ( 1._r8 + (300._r8/(-obu))**0.666_r8) + else + vds_tmp = 2.e-3_r8*ustar + endif + + vds = vds_tmp + + ! Calculate a 10-m wind (10m + z0m + d) + ! For now, this will not be the same as the 10-m wind calculated for the dust + ! model because the ELM stability functions are used here, not the LSM stability + ! functions used in the dust model. We will eventually change the dust model to be + ! consistent with the following formulation. + ! Note that the 10-m wind calculated this way could actually be larger than the + ! atmospheric forcing wind because 1) this includes the convective velocity, 2) + ! this includes the 1 m/s minimum wind threshold + + ! If forcing height is less than or equal to 10m, then set 10-m wind to um + if (zldis-z0m <= 10._r8) then + u10_with_gusts_elm = um + else + if (zeta < -zetam) then + u10_with_gusts_elm = um - ( ustar/vkc*(log(-zetam*obu/(10._r8+z0m)) & + - StabilityFunc1(-zetam) & + + StabilityFunc1((10._r8+z0m)/obu) & + + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) ) + else if (zeta < 0._r8) then + u10_with_gusts_elm = um - ( ustar/vkc*(log(zldis/(10._r8+z0m)) & + - StabilityFunc1(zeta) & + + StabilityFunc1((10._r8+z0m)/obu)) ) + else if (zeta <= 1._r8) then + u10_with_gusts_elm = um - ( ustar/vkc*(log(zldis/(10._r8+z0m)) & + + 5._r8*zeta - 5._r8*(10._r8+z0m)/obu) ) + else + u10_with_gusts_elm = um - ( ustar/vkc*(log(obu/(10._r8+z0m)) & + + 5._r8 - 5._r8*(10._r8+z0m)/obu & + + (5._r8*log(zeta)+zeta-1._r8)) ) + end if + end if + va = um + ! Estimate u10 with effects of gustiness removed. + u10_elm = u10_with_gusts_elm * sqrt(max(0., um**2 - ugust**2)) / um + + !===================! + !Temperature Profile! + !===================! + zldis = forc_hgt_t_patch - displa + zeta = zldis/obu + if (zeta < -zetat) then + temp1 = vkc/(log(-zetat*obu/z0h)& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h/obu) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp1 = vkc/(log(zldis/z0h) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0h/obu)) + else if (zeta <= 1._r8) then + temp1 = vkc/(log(zldis/z0h) + 5._r8*zeta - 5._r8*z0h/obu) + else + temp1 = vkc/(log(obu/z0h) + 5._r8 - 5._r8*z0h/obu & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + !=================! + !Humidity Profile ! + !=================! + if (forc_hgt_q_patch == forc_hgt_t_patch .and. z0q == z0h) then + temp2 = temp1 + else + zldis = forc_hgt_q_patch-displa + zeta = zldis/obu + if (zeta < -zetat) then + temp2 = vkc/(log(-zetat*obu/z0q) & + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0q/obu) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp2 = vkc/(log(zldis/z0q) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0q/obu)) + else if (zeta <= 1._r8) then + temp2 = vkc/(log(zldis/z0q) + 5._r8*zeta-5._r8*z0q/obu) + else + temp2 = vkc/(log(obu/z0q) + 5._r8 - 5._r8*z0q/obu & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + endif + + ! Temperature profile applied at 2-m + + zldis = 2.0_r8 + z0h + zeta = zldis/obu + if (zeta < -zetat) then + temp12m = vkc/(log(-zetat*obu/z0h)& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h/obu) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp12m = vkc/(log(zldis/z0h) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0h/obu)) + else if (zeta <= 1._r8) then + temp12m = vkc/(log(zldis/z0h) + 5._r8*zeta - 5._r8*z0h/obu) + else + temp12m = vkc/(log(obu/z0h) + 5._r8 - 5._r8*z0h/obu & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + + ! Humidity profile applied at 2-m + + if (z0q == z0h) then + temp22m = temp12m + else + zldis = 2.0_r8 + z0q + zeta = zldis/obu + if (zeta < -zetat) then + temp22m = vkc/(log(-zetat*obu/z0q) - & + StabilityFunc2(-zetat) + StabilityFunc2(z0q/obu) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp22m = vkc/(log(zldis/z0q) - & + StabilityFunc2(zeta)+StabilityFunc2(z0q/obu)) + else if (zeta <= 1._r8) then + temp22m = vkc/(log(zldis/z0q) + 5._r8*zeta-5._r8*z0q/obu) + else + temp22m = vkc/(log(obu/z0q) + 5._r8 - 5._r8*z0q/obu & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + end if + + ! diagnose 10-m wind for dust model (dstmbl.F) + ! Notes from C. Zender's dst.F: + ! According to Bon96 p. 62, the displacement height d (here displa) is + ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). + ! Therefore d <= 0.034*z1 and may safely be neglected. + ! Code from LSM routine SurfaceTemperature was used to obtain u10 + + zldis = forc_hgt_u_patch - displa + zeta = zldis/obu + if (min(zeta, 1._r8) < 0._r8) then + tmp1 = (1._r8 - 16._r8*min(zeta,1._r8))**0.25_r8 + tmp2 = log((1._r8+tmp1*tmp1)/2._r8) + tmp3 = log((1._r8+tmp1)/2._r8) + fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 + else + fmnew = -5._r8*min(zeta,1._r8) + endif + if (iter == 1) then + fm = fmnew + else + fm = 0.5_r8 * (fm+fmnew) + end if + zeta10 = min(10._r8/obu, 1._r8) + if (zeta == 0._r8) zeta10 = 0._r8 + if (zeta10 < 0._r8) then + tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 + tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) + tmp3 = log((1.0_r8 + tmp1)/2.0_r8) + fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 + else ! not stable + fm10 = -5.0_r8 * zeta10 + end if + + tmp4 = log( max( 1.0_8, forc_hgt_u_patch / 10._r8) ) + u10 = ur - ustar/vkc * (tmp4 - fm + fm10) + fv = ustar + end subroutine FrictionVelocity_noloop + + !------------------------------------------------------------------------------ + subroutine FrictionVelocity_loops(lbn, ubn, fn, filtern, & + displa, z0m, z0h, z0q, & + obu, iter, ur, um, ugust, ustar, & + temp1, temp2, temp12m, temp22m, fm,frictionvel_vars,converged, landunit_index) +! !DESCRIPTION: +! Calculation of the friction velocity, relation for potential +! temperature and humidity profiles of surface boundary layer. +! The scheme is based on the work of Zeng et al. (1998): +! Intercomparison of bulk aerodynamic algorithms for the computation +! of sea surface fluxes using TOGA CORE and TAO data. J. Climate, +! Vol. 11, 2628-2644. +! +! !USES: +use elm_varcon, only : vkc + +implicit none +! +! !ARGUMENTS: +integer , intent(in) :: lbn, ubn ! pft/landunit array bounds +integer , intent(in) :: fn ! number of filtered pft/landunit elements +integer , intent(in) :: filtern(fn) ! pft/landunit filter +real(r8) , intent(in) :: displa ( lbn: ) ! displacement height (m) [lbn:ubn] +real(r8) , intent(in) :: z0m ( lbn: ) ! roughness length over vegetation, momentum [m] [lbn:ubn] +real(r8) , intent(in) :: z0h ( lbn: ) ! roughness length over vegetation, sensible heat [m] [lbn:ubn] +real(r8) , intent(in) :: z0q ( lbn: ) ! roughness length over vegetation, latent heat [m] [lbn:ubn] +real(r8) , intent(in) :: obu (1: ) ! monin-obukhov length (m) [lbn:ubn] +integer , intent(in) :: iter ! iteration number +real(r8) , intent(in) :: ur (1: ) ! wind speed at reference height [m/s] [lbn:ubn] +real(r8) , intent(in) :: um (1: ) ! wind speed including the stablity effect [m/s] [lbn:ubn] +real(r8) , intent(in) :: ugust (1: ) ! Gustiness wind speed [m/s] [lbn:ubn] +real(r8) , intent(out) :: ustar (1: ) ! friction velocity [m/s] [lbn:ubn] +real(r8) , intent(out) :: temp1 (1: ) ! relation for potential temperature profile [lbn:ubn] +real(r8) , intent(out) :: temp2 (1: ) ! relation for specific humidity profile [lbn:ubn] +real(r8) , intent(out) :: temp12m (1: ) ! relation for potential temperature profile applied at 2-m [lbn:ubn] +real(r8) , intent(out) :: temp22m (1: ) ! relation for specific humidity profile applied at 2-m [lbn:ubn] +real(r8) , intent(inout) :: fm (1: ) ! diagnose 10m wind (DUST only) [lbn:ubn] +type(frictionvel_type) , intent(inout) :: frictionvel_vars +logical, intent(in) :: converged(lbn:) +logical , intent(in), optional :: landunit_index ! optional argument that defines landunit or pft level +! +! !LOCAL VARIABLES: +real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile) +real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile) +integer :: f ! pft/landunit filter index +integer :: n ! pft/landunit index +integer :: g ! gridcell index +integer :: pp ! pfti,pftf index +integer :: pfti, pftf +real(r8) :: zldis ! reference height "minus" zero displacement heght [m] +real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory +real(r8) :: tmp1,tmp2,tmp3,tmp4 ! Used to diagnose the 10 meter wind +real(r8) :: fmnew ! Used to diagnose the 10 meter wind +real(r8) :: fm10 ! Used to diagnose the 10 meter wind +real(r8) :: zeta10 ! Used to diagnose the 10 meter wind +real(r8) :: vds_tmp ! Temporary for dry deposition velocity +logical :: is_landunit_index +!------------------------------------------------------------------------------ +associate( & + forc_hgt_u_patch => frictionvel_vars%forc_hgt_u_patch , & ! Input: [real(r8) (:) ] observational height of wind at pft level [m] + forc_hgt_t_patch => frictionvel_vars%forc_hgt_t_patch , & ! Input: [real(r8) (:) ] observational height of temperature at pft level [m] + forc_hgt_q_patch => frictionvel_vars%forc_hgt_q_patch , & ! Input: [real(r8) (:) ] observational height of specific humidity at pft level [m] + vds => frictionvel_vars%vds_patch , & ! Output: [real(r8) (:) ] dry deposition velocity term (m/s) (for SO4 NH4NO3) + u10 => frictionvel_vars%u10_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) (for dust model) + u10_elm => frictionvel_vars%u10_elm_patch , & ! Output: [real(r8) (:) ] 10-m wind (m/s) + u10_with_gusts_elm=>frictionvel_vars%u10_with_gusts_elm_patch, & ! Output: [real(r8) (:) ] 10-m wind with gusts(m/s) + va => frictionvel_vars%va_patch , & ! Output: [real(r8) (:) ] atmospheric wind speed plus convective velocity (m/s) + fv => frictionvel_vars%fv_patch & ! Output: [real(r8) (:) ] friction velocity (m/s) (for dust model) + ) + + ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions. + is_landunit_index = present(landunit_index) + !$acc enter data copyin(is_landunit_index) + + !$acc parallel loop independent gang vector default(present) + do f = 1, fn + n = filtern(f) + if(converged(n)) cycle + + if (is_landunit_index) then + g = lun_pp%gridcell(n) + pfti = lun_pp%pfti(n) + pftf = lun_pp%pftf(n) + else + g = veg_pp%gridcell(n) + end if + + ! Wind profile + + if (is_landunit_index) then + zldis = forc_hgt_u_patch(pfti)-displa(n) + else + zldis = forc_hgt_u_patch(n)-displa(n) + end if + + zeta = zldis/obu(f) + if (zeta < -zetam) then + ustar(f) = vkc*um(f)/(log(-zetam*obu(f)/z0m(n))& + - StabilityFunc1(-zetam) & + + StabilityFunc1(z0m(n)/obu(f)) & + + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) + else if (zeta < 0._r8) then + ustar(f) = vkc*um(f)/(log(zldis/z0m(n))& + - StabilityFunc1(zeta)& + + StabilityFunc1(z0m(n)/obu(f))) + else if (zeta <= 1._r8) then + ustar(f) = vkc*um(f)/(log(zldis/z0m(n)) + 5._r8*zeta -5._r8*z0m(n)/obu(f)) + else + ustar(f) = vkc*um(f)/(log(obu(f)/z0m(n))+5._r8-5._r8*z0m(n)/obu(f) & + +(5._r8*log(zeta)+zeta-1._r8)) + end if + + if (zeta < 0._r8) then + vds_tmp = 2.e-3_r8*ustar(f) * ( 1._r8 + (300._r8/(-obu(f)))**0.666_r8) + else + vds_tmp = 2.e-3_r8*ustar(f) + endif + + if (is_landunit_index) then + !$acc loop seq + do pp = pfti,pftf + vds(pp) = vds_tmp + end do + else + vds(n) = vds_tmp + end if + + ! Calculate a 10-m wind (10m + z0m + d) + ! For now, this will not be the same as the 10-m wind calculated for the dust + ! model because the CLM stability functions are used here, not the LSM stability + ! functions used in the dust model. We will eventually change the dust model to be + ! consistent with the following formulation. + ! Note that the 10-m wind calculated this way could actually be larger than the + ! atmospheric forcing wind because 1) this includes the convective velocity, 2) + ! this includes the 1 m/s minimum wind threshold + + ! If forcing height is less than or equal to 10m, then set 10-m wind to um + if (is_landunit_index) then + !$acc loop seq + do pp = pfti,pftf + if (zldis-z0m(n) <= 10._r8) then + u10_with_gusts_elm(pp) = um(f) + else + if (zeta < -zetam) then + u10_with_gusts_elm(pp) = um(f) - ( ustar(f)/vkc*(log(-zetam*obu(f)/(10._r8+z0m(n))) & + - StabilityFunc1(-zetam) & + + StabilityFunc1((10._r8+z0m(n))/obu(f)) & + + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) ) + else if (zeta < 0._r8) then + u10_with_gusts_elm(pp) = um(f) - ( ustar(f)/vkc*(log(zldis/(10._r8+z0m(n))) & + - StabilityFunc1(zeta) & + + StabilityFunc1((10._r8+z0m(n))/obu(f))) ) + else if (zeta <= 1._r8) then + u10_with_gusts_elm(pp) = um(f) - ( ustar(f)/vkc*(log(zldis/(10._r8+z0m(n))) & + + 5._r8*zeta - 5._r8*(10._r8+z0m(n))/obu(f)) ) + else + u10_with_gusts_elm(pp) = um(f) - ( ustar(f)/vkc*(log(obu(f)/(10._r8+z0m(n))) & + + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) ) + + end if + end if + va(pp) = um(f) + ! Estimate u10 with effects of gustiness removed. + u10_elm(pp) = u10_with_gusts_elm(pp) * sqrt(max(0., um(f)**2 - ugust(f)**2)) / um(f) + end do + else + if (zldis-z0m(n) <= 10._r8) then + u10_with_gusts_elm(n) = um(f) + else + if (zeta < -zetam) then + u10_with_gusts_elm(n) = um(f) - ( ustar(f)/vkc*(log(-zetam*obu(f)/(10._r8+z0m(n))) & + - StabilityFunc1(-zetam) & + + StabilityFunc1((10._r8+z0m(n))/obu(f)) & + + 1.14_r8*((-zeta)**0.333_r8-(zetam)**0.333_r8)) ) + else if (zeta < 0._r8) then + u10_with_gusts_elm(n) = um(f) - ( ustar(f)/vkc*(log(zldis/(10._r8+z0m(n))) & + - StabilityFunc1(zeta) & + + StabilityFunc1((10._r8+z0m(n))/obu(f))) ) + else if (zeta <= 1._r8) then + u10_with_gusts_elm(n) = um(f) - ( ustar(f)/vkc*(log(zldis/(10._r8+z0m(n))) & + + 5._r8*zeta - 5._r8*(10._r8+z0m(n))/obu(f)) ) + else + u10_with_gusts_elm(n) = um(f) - ( ustar(f)/vkc*(log(obu(f)/(10._r8+z0m(n))) & + + 5._r8 - 5._r8*(10._r8+z0m(n))/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) ) + end if + end if + va(n) = um(f) + ! Estimate u10 with effects of gustiness removed. + u10_elm(n) = u10_with_gusts_elm(n) * sqrt(max(0., um(f)**2 - ugust(f)**2)) / um(f) + end if + + !===================! + !Temperature Profile! + !===================! + if (is_landunit_index) then + zldis = forc_hgt_t_patch(pfti)-displa(n) + else + zldis = forc_hgt_t_patch(n)-displa(n) + end if + zeta = zldis/obu(f) + if (zeta < -zetat) then + temp1(f) = vkc/(log(-zetat*obu(f)/z0h(n))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(n)/obu(f)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp1(f) = vkc/(log(zldis/z0h(n)) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0h(n)/obu(f))) + else if (zeta <= 1._r8) then + temp1(f) = vkc/(log(zldis/z0h(n)) + 5._r8*zeta - 5._r8*z0h(n)/obu(f)) + else + temp1(f) = vkc/(log(obu(f)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + !=================! + !Humidity Profile ! + !=================! + if (is_landunit_index) then + if (forc_hgt_q_patch(pfti) == forc_hgt_t_patch(pfti) .and. z0q(n) == z0h(n)) then + temp2(f) = temp1(f) + else + zldis = forc_hgt_q_patch(pfti)-displa(n) + zeta = zldis/obu(f) + if (zeta < -zetat) then + temp2(f) = vkc/(log(-zetat*obu(f)/z0q(n)) & + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0q(n)/obu(f)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp2(f) = vkc/(log(zldis/z0q(n)) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0q(n)/obu(f))) + else if (zeta <= 1._r8) then + temp2(f) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(f)) + else + temp2(f) = vkc/(log(obu(f)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + end if + else + if (forc_hgt_q_patch(n) == forc_hgt_t_patch(n) .and. z0q(n) == z0h(n)) then + temp2(f) = temp1(f) + else + zldis = forc_hgt_q_patch(n)-displa(n) + zeta = zldis/obu(f) + if (zeta < -zetat) then + temp2(f) = vkc/(log(-zetat*obu(f)/z0q(n)) & + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0q(n)/obu(f)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp2(f) = vkc/(log(zldis/z0q(n)) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0q(n)/obu(f))) + else if (zeta <= 1._r8) then + temp2(f) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(f)) + else + temp2(f) = vkc/(log(obu(f)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + endif + endif + + ! Temperature profile applied at 2-m + + zldis = 2.0_r8 + z0h(n) + zeta = zldis/obu(f) + if (zeta < -zetat) then + temp12m(f) = vkc/(log(-zetat*obu(f)/z0h(n))& + - StabilityFunc2(-zetat) & + + StabilityFunc2(z0h(n)/obu(f)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp12m(f) = vkc/(log(zldis/z0h(n)) & + - StabilityFunc2(zeta) & + + StabilityFunc2(z0h(n)/obu(f))) + else if (zeta <= 1._r8) then + temp12m(f) = vkc/(log(zldis/z0h(n)) + 5._r8*zeta - 5._r8*z0h(n)/obu(f)) + else + temp12m(f) = vkc/(log(obu(f)/z0h(n)) + 5._r8 - 5._r8*z0h(n)/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + + ! Humidity profile applied at 2-m + + if (z0q(n) == z0h(n)) then + temp22m(f) = temp12m(f) + else + zldis = 2.0_r8 + z0q(n) + zeta = zldis/obu(f) + if (zeta < -zetat) then + temp22m(f) = vkc/(log(-zetat*obu(f)/z0q(n)) - & + StabilityFunc2(-zetat) + StabilityFunc2(z0q(n)/obu(f)) & + + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta)**(-0.333_r8))) + else if (zeta < 0._r8) then + temp22m(f) = vkc/(log(zldis/z0q(n)) - & + StabilityFunc2(zeta)+StabilityFunc2(z0q(n)/obu(f))) + else if (zeta <= 1._r8) then + temp22m(f) = vkc/(log(zldis/z0q(n)) + 5._r8*zeta-5._r8*z0q(n)/obu(f)) + else + temp22m(f)= vkc/(log(obu(f)/z0q(n)) + 5._r8 - 5._r8*z0q(n)/obu(f) & + + (5._r8*log(zeta)+zeta-1._r8)) + end if + end if + + ! diagnose 10-m wind for dust model (dstmbl.F) + ! Notes from C. Zender's dst.F: + ! According to Bon96 p. 62, the displacement height d (here displa) is + ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees). + ! Therefore d <= 0.034*z1 and may safely be neglected. + ! Code from LSM routine SurfaceTemperature was used to obtain u10 + if (is_landunit_index) then + zldis = forc_hgt_u_patch(pfti)-displa(n) + else + zldis = forc_hgt_u_patch(n)-displa(n) + end if + + zeta = zldis/obu(f) + if (min(zeta, 1._r8) < 0._r8) then + tmp1 = (1._r8 - 16._r8*min(zeta,1._r8))**0.25_r8 + tmp2 = log((1._r8+tmp1*tmp1)/2._r8) + tmp3 = log((1._r8+tmp1)/2._r8) + fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8 + else + fmnew = -5._r8*min(zeta,1._r8) + endif + if (iter == 1) then + fm(f) = fmnew + else + fm(f) = 0.5_r8 * (fm(f)+fmnew) + end if + zeta10 = min(10._r8/obu(f), 1._r8) + if (zeta == 0._r8) zeta10 = 0._r8 + if (zeta10 < 0._r8) then + tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8 + tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8) + tmp3 = log((1.0_r8 + tmp1)/2.0_r8) + fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8 + else ! not stable + fm10 = -5.0_r8 * zeta10 + end if + + if (is_landunit_index) then + tmp4 = log( max( 1.0_8, forc_hgt_u_patch(pfti) / 10._r8) ) + else + tmp4 = log( max( 1.0_8, forc_hgt_u_patch(n) / 10._r8) ) + end if + if (is_landunit_index) then + !$acc loop seq + do pp = pfti,pftf + u10(pp) = ur(f) - ustar(f)/vkc * (tmp4 - fm(f) + fm10) + fv(pp) = ustar(f) + end do + else + u10(n) = ur(f) - ustar(f)/vkc * (tmp4 - fm(f) + fm10) + fv(n) = ustar(f) + end if + end do !! do loop of fn + + !$acc exit data delete(is_landunit_index) + end associate + +end subroutine FrictionVelocity_loops + !------------------------------------------------------------------------------ real(r8) function StabilityFunc1(zeta) @@ -456,25 +714,23 @@ subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) ! ! !ARGUMENTS: implicit none - real(r8), intent(in) :: ur ! wind speed at reference height [m/s] - real(r8), intent(in) :: thv ! virtual potential temperature (kelvin) - real(r8), intent(in) :: dthv ! diff of vir. poten. temp. 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(in),value :: ur ! wind speed at reference height [m/s] + real(r8), intent(in),value :: thv ! virtual potential temperature (kelvin) + real(r8), intent(in),value :: dthv ! diff of vir. poten. temp. between ref. height and surface + real(r8), intent(in),value :: zldis ! reference height "minus" zero displacement heght [m] + real(r8), intent(in),value :: z0m ! roughness length, momentum [m] real(r8), intent(out) :: um ! wind speed including the stability effect [m/s] real(r8), intent(out) :: obu ! Obukhov length scale (m) ! ! !LOCAL VARIABLES: - real(r8) :: wc ! convective velocity [m/s] + real(r8),parameter :: wc=0.5_r8 ! convective velocity [m/s] + real(r8),parameter :: ustar=0.06_r8 ! friction velocity [m/s] real(r8) :: rib ! bulk Richardson number real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory - real(r8) :: ustar ! friction velocity [m/s] !----------------------------------------------------------------------- ! Initial values of u* and convective velocity - ustar=0.06_r8 - wc=0.5_r8 if (dthv >= 0._r8) then um=max(ur,0.1_r8) else @@ -482,7 +738,6 @@ subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu) endif rib=grav*zldis*dthv/(thv*um*um) - if (rib >= 0._r8) then ! neutral or stable zeta = rib*log(zldis/z0m)/(1._r8-5._r8*min(rib,0.19_r8)) zeta = min(2._r8,max(zeta,0.01_r8 )) diff --git a/components/elm/src/biogeophys/HydrologyDrainageMod.F90 b/components/elm/src/biogeophys/HydrologyDrainageMod.F90 index d3f307400775..b485aca80d8c 100644 --- a/components/elm/src/biogeophys/HydrologyDrainageMod.F90 +++ b/components/elm/src/biogeophys/HydrologyDrainageMod.F90 @@ -23,6 +23,7 @@ module HydrologyDrainageMod use elm_instMod , only : ep_betr use timeinfoMod + use elm_instMod , only : ep_betr ! ! !PUBLIC TYPES: implicit none @@ -44,9 +45,7 @@ subroutine HydrologyDrainage(bounds, & soilhydrology_vars, soilstate_vars ) ! !DESCRIPTION: ! Calculates soil/snow hydrology with drainage (subsurface runoff) - ! ! !USES: - !$acc routine seq use landunit_varcon , only : istice, istwet, istsoil, istice_mec, istcrop, istice use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv, icol_sunwall, icol_shadewall use elm_varcon , only : denh2o, denice, secspday, frac_to_downhill @@ -82,6 +81,7 @@ subroutine HydrologyDrainage(bounds, & real(r8) :: dtime real(r8) :: temp_to_downhill, temp_mass integer :: g,t,l,c,j,fc,tpu_ind, downhill_t ! indices + real(r8) :: sumtot, sumice, sumliq !----------------------------------------------------------------------- associate( & @@ -131,37 +131,31 @@ subroutine HydrologyDrainage(bounds, & qflx_to_downhill => col_wf%qflx_to_downhill & ! Output: [real(r8) (:) ] flux transferred to downhill topounit (mm H2O/s) ) - ! Determine time step and step size - - dtime = dtime_mod - + !$acc enter data create(sumtot,sumice,sumliq) if (use_vichydro) then call ELMVICMap(bounds, num_hydrologyc, filter_hydrologyc, & soilhydrology_vars) endif -#ifndef _OPENACC if (use_betr) then call ep_betr%BeTRSetBiophysForcing(bounds, col_pp, veg_pp, 1, nlevsoi, waterstate_vars=col_ws) call ep_betr%PreDiagSoilColWaterFlux(num_hydrologyc, filter_hydrologyc) endif -#endif if (.not. use_vsfm) then call Drainage(bounds, num_hydrologyc, filter_hydrologyc, & num_urbanc, filter_urbanc,& - soilhydrology_vars, soilstate_vars, ocn2lnd_vars, dtime) + soilhydrology_vars, soilstate_vars, ocn2lnd_vars, dtime_mod) endif -#ifndef _OPENACC if (use_betr) then call ep_betr%BeTRSetBiophysForcing(bounds, col_pp, veg_pp, 1, nlevsoi, waterstate_vars=col_ws, & waterflux_vars=col_wf) call ep_betr%DiagDrainWaterFlux(num_hydrologyc, filter_hydrologyc) call ep_betr%RetrieveBiogeoFlux(bounds, 1, nlevsoi, waterflux_vars=col_wf) endif -#endif + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevgrnd do fc = 1, num_nolakec c = filter_nolakec(fc) @@ -173,6 +167,7 @@ subroutine HydrologyDrainage(bounds, & end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -187,18 +182,23 @@ subroutine HydrologyDrainage(bounds, & end if end do - do j = 1, nlevgrnd - do fc = 1, num_nolakec - c = filter_nolakec(fc) + !$acc parallel loop independent gang worker default(present) private(sumtot,sumliq,sumice) + do fc = 1, num_nolakec + c = filter_nolakec(fc) + sumtot = 0._r8; sumliq = 0._r8; sumice = 0._r8; + !$acc loop vector reduction(+:sumtot,sumliq,sumice) + do j = 1, nlevgrnd if ((ctype(c) == icol_sunwall .or. ctype(c) == icol_shadewall & - .or. ctype(c) == icol_roof) .and. j > nlevurb) then - + .or. ctype(c) == icol_roof) .and. j > nlevurb ) then else - endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + h2osoi_liq(c,j) - h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + h2osoi_ice(c,j) + sumtot = sumtot + h2osoi_ice(c,j) + h2osoi_liq(c,j) + sumliq = sumliq + h2osoi_liq(c,j) + sumice = sumice + h2osoi_ice(c,j) end if - end do + end do + endwb(c) = endwb(c) + sumtot + h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + sumliq + h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + sumice end do ! --------------------------------------------------------------------------------- @@ -207,6 +207,7 @@ subroutine HydrologyDrainage(bounds, & ! Other orthogonal modules should not need to worry about this term, ! and it should be zero in all other cases and all other columns. ! --------------------------------------------------------------------------------- + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) endwb(c) = endwb(c) + total_plant_stored_h2o(c) @@ -220,7 +221,7 @@ subroutine HydrologyDrainage(bounds, & ! 2) If using glc_dyn_runoff_routing=T, zero qflx_snwcp_ice: qflx_snwcp_ice is the flux ! sent to ice runoff, but for glc_dyn_runoff_routing=T, we do NOT want this to be ! sent to ice runoff (instead it is sent to CISM). - + !$acc parallel loop independent gang vector default(present) do c = bounds%begc,bounds%endc qflx_glcice_frz(c) = 0._r8 qflx_glcice_frz_diag(c) = 0._r8 @@ -230,6 +231,8 @@ subroutine HydrologyDrainage(bounds, & qflx_glcice_diag(c) = qflx_glcice_diag(c) + qflx_glcice_frz_diag(c) endif end do + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_do_smb_c c = filter_do_smb_c(fc) l = col_pp%landunit(c) @@ -251,10 +254,12 @@ subroutine HydrologyDrainage(bounds, & ! Determine wetland and land ice hydrology (must be placed here ! since need snow updated from CombineSnowLayers) + !$acc parallel loop independent gang vector default(present) do c = bounds%begc,bounds%endc qflx_irr_demand(c) = 0._r8 end do - + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -272,7 +277,7 @@ subroutine HydrologyDrainage(bounds, & qflx_infl(c) = 0._r8 qflx_lnd2ocn(c) = 0._r8 qflx_qrgwl(c) = forc_rain(t) + forc_snow(t) + qflx_floodg(g) - qflx_evap_tot(c) - qflx_snwcp_ice(c) - & - (endwb(c)-begwb(c))/dtime + (endwb(c)-begwb(c))/dtime_mod ! With glc_dyn_runoff_routing = false (the less realistic way, typically used ! when NOT coupling to CISM), excess snow immediately runs off, whereas melting @@ -348,6 +353,7 @@ subroutine HydrologyDrainage(bounds, & end do + !$acc exit data delete(sumtot,sumice,sumliq) end associate end subroutine HydrologyDrainage diff --git a/components/elm/src/biogeophys/HydrologyNoDrainageMod.F90 b/components/elm/src/biogeophys/HydrologyNoDrainageMod.F90 index 218838b130e5..cc9df61d820d 100644 --- a/components/elm/src/biogeophys/HydrologyNoDrainageMod.F90 +++ b/components/elm/src/biogeophys/HydrologyNoDrainageMod.F90 @@ -23,8 +23,6 @@ Module HydrologyNoDrainageMod use VegetationType , only : veg_pp use TopounitDataType , only : top_as, top_af ! Atmospheric state and flux variables use elm_instMod , only : alm_fates , ep_betr - - use timeinfoMod ! ! !PUBLIC TYPES: @@ -45,8 +43,9 @@ subroutine HydrologyNoDrainage(bounds, & num_urbanc, filter_urbanc, & num_snowc, filter_snowc, & num_nosnowc, filter_nosnowc, canopystate_vars, & - atm2lnd_vars, ocn2lnd_vars, lnd2atm_vars, soilstate_vars, & - energyflux_vars, soilhydrology_vars, aerosol_vars) + atm2lnd_vars, ocn2lnd_vars, soilstate_vars, & + soilhydrology_vars, aerosol_vars) + ! !DESCRIPTION: ! This is the main subroutine to execute the calculation of soil/snow ! hydrology @@ -63,7 +62,6 @@ subroutine HydrologyNoDrainage(bounds, & ! -> DivideExtraSnowLayers: subdivide up to 16 snow layers that are thicker than maximum ! ! !USES: - !$acc routine seq use elm_varcon , only : denh2o, denice, hfus, grav, tfrz use landunit_varcon , only : istice, istwet, istsoil, istice_mec, istcrop, istdlak use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv, icol_sunwall @@ -74,7 +72,7 @@ subroutine HydrologyNoDrainage(bounds, & use SnowHydrologyMod , only : SnowWater, BuildSnowFilter use SoilHydrologyMod , only : ELMVICMap, SurfaceRunoff, Infiltration, WaterTable use SoilWaterMovementMod , only : SoilWater - use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type + ! use SoilWaterRetentionCurveMod, only : soil_water_retention_curve_type use elm_varctl , only : use_vsfm use SoilHydrologyMod , only : DrainageVSFM use SoilWaterMovementMod , only : Compute_EffecRootFrac_And_VertTranSink @@ -93,15 +91,12 @@ subroutine HydrologyNoDrainage(bounds, & integer , intent(inout) :: filter_snowc(:) ! column filter for snow points integer , intent(inout) :: num_nosnowc ! number of column non-snow points integer , intent(inout) :: filter_nosnowc(:) ! column filter for non-snow points + type(canopystate_type) , intent(in) :: canopystate_vars type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(ocn2lnd_type) , intent(in) :: ocn2lnd_vars - type(lnd2atm_type) , intent(in) :: lnd2atm_vars type(soilstate_type) , intent(inout) :: soilstate_vars - type(energyflux_type) , intent(in) :: energyflux_vars - type(canopystate_type) , intent(in) :: canopystate_vars - type(aerosol_type) , intent(inout) :: aerosol_vars type(soilhydrology_type) , intent(inout) :: soilhydrology_vars - real(r8) :: dtime ! land model time step (sec) + type(aerosol_type) , intent(inout) :: aerosol_vars ! ! !LOCAL VARIABLES: @@ -109,36 +104,37 @@ subroutine HydrologyNoDrainage(bounds, & integer :: nlevbed ! # layers to bedrock real(r8) :: psi,vwc,fsattmp,psifrz ! temporary variables for soilpsi calculation real(r8) :: watdry ! temporary - real(r8) :: rwat(bounds%begc:bounds%endc) ! soil water wgted by depth to maximum depth of 0.5 m - real(r8) :: swat(bounds%begc:bounds%endc) ! same as rwat but at saturation - real(r8) :: rz(bounds%begc:bounds%endc) ! thickness of soil layers contributing to rwat (m) real(r8) :: h2osoi_liq_saved(bounds%begc:bounds%endc) ! h2osoi_liq_col in topmost layer before calling SoilWater + real(r8) :: rwat(1:num_hydrologyc) ! soil water wgted by depth to maximum depth of 0.5 m + real(r8) :: swat(1:num_hydrologyc) ! same as rwat but at saturation + real(r8) :: rz (1:num_hydrologyc) ! thickness of soil layers contributing to rwat (m) real(r8) :: tsw ! volumetric soil water to 0.5 m real(r8) :: stsw ! volumetric soil water to 0.5 m at saturation real(r8) :: fracl ! fraction of soil layer contributing to 10cm total soil water real(r8) :: s_node ! soil wetness (-) - real(r8) :: icefrac(bounds%begc:bounds%endc,1:nlevgrnd) + real(r8) :: sum1, sum2, sum3,sum4 + real :: startt, stopt !----------------------------------------------------------------------- - associate( & - z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer depth (m) - dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness depth (m) - zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface depth (m) - snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers - nlev2bed => col_pp%nlevbed , & ! Input: [integer (:) ] number of layers to bedrock - ctype => col_pp%itype , & ! Input: [integer (:) ] column type + associate( & + z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer depth (m) + dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness depth (m) + zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface depth (m) + snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers + nlev2bed => col_pp%nlevbed , & ! Input: [integer (:) ] number of layers to bedrock + ctype => col_pp%itype , & ! Input: [integer (:) ] column type forc_wind => top_as%windbot , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) - t_h2osfc => col_es%t_h2osfc , & ! Input: [real(r8) (:) ] surface water temperature - dTdz_top => col_es%dTdz_top , & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] ! - snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] snow temperature in top layer (col) [K] - t_soisno => col_es%t_soisno , & ! Output: [real(r8) (:,:) ] soil temperature (Kelvin) - t_grnd => col_es%t_grnd , & ! Output: [real(r8) (:) ] ground temperature (Kelvin) - t_grnd_u => col_es%t_grnd_u , & ! Output: [real(r8) (:) ] Urban ground temperature (Kelvin) - t_grnd_r => col_es%t_grnd_r , & ! Output: [real(r8) (:) ] Rural ground temperature (Kelvin) - t_soi_10cm => col_es%t_soi10cm , & ! Output: [real(r8) (:) ] soil temperature in top 10cm of soil (Kelvin) - tsoi17 => col_es%t_soi17cm , & ! Output: [real(r8) (:) ] soil temperature in top 17cm of soil (Kelvin) + t_h2osfc => col_es%t_h2osfc , & ! Input: [real(r8) (:) ] surface water temperature + dTdz_top => col_es%dTdz_top , & ! Output: [real(r8) (:) ] temperature gradient in top layer (col) [K m-1] ! + snot_top => col_es%snot_top , & ! Output: [real(r8) (:) ] snow temperature in top layer (col) [K] + t_soisno => col_es%t_soisno , & ! Output: [real(r8) (:,:) ] soil temperature (Kelvin) + t_grnd => col_es%t_grnd , & ! Output: [real(r8) (:) ] ground temperature (Kelvin) + t_grnd_u => col_es%t_grnd_u , & ! Output: [real(r8) (:) ] Urban ground temperature (Kelvin) + t_grnd_r => col_es%t_grnd_r , & ! Output: [real(r8) (:) ] Rural ground temperature (Kelvin) + t_soi_10cm => col_es%t_soi10cm , & ! Output: [real(r8) (:) ] soil temperature in top 10cm of soil (Kelvin) + tsoi17 => col_es%t_soi17cm , & ! Output: [real(r8) (:) ] soil temperature in top 17cm of soil (Kelvin) snow_depth => col_ws%snow_depth , & ! Input: [real(r8) (:) ] snow height of snow covered area (m) snowdp => col_ws%snowdp , & ! Input: [real(r8) (:) ] gridcell averaged snow height (m) @@ -170,20 +166,23 @@ subroutine HydrologyNoDrainage(bounds, & smpmin => soilstate_vars%smpmin_col , & ! Input: [real(r8) (:) ] restriction for min of soil potential (mm) soilpsi => soilstate_vars%soilpsi_col & ! Output: [real(r8) (:,:) ] soil water potential in each soil layer (MPa) ) + !$acc enter data create(& + !$acc rwat(:), & + !$acc swat(:), & + !$acc rz(:), & + !$acc psi, & + !$acc sum1, & + !$acc sum2, & + !$acc sum3) - dtime = dtime_mod ! Determine initial snow/no-snow filters (will be modified possibly by ! routines CombineSnowLayers and DivideSnowLayers below - - call BuildSnowFilter(bounds, num_nolakec, filter_nolakec, & + call BuildSnowFilter(num_nolakec, filter_nolakec, & num_snowc, filter_snowc, num_nosnowc, filter_nosnowc) - - + ! Determine the change of snow mass and the snow water onto soil - call SnowWater(bounds, num_snowc, filter_snowc, num_nosnowc, filter_nosnowc, & atm2lnd_vars, aerosol_vars) - ! mapping soilmoist from CLM to VIC layers for runoff calculations if (use_vichydro) then call ELMVICMap(bounds, num_hydrologyc, filter_hydrologyc, & @@ -191,65 +190,55 @@ subroutine HydrologyNoDrainage(bounds, & end if call SurfaceRunoff(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filter_urbanc, & - soilhydrology_vars, soilstate_vars, dtime) + soilhydrology_vars, soilstate_vars, dtime_mod) !------------------------------------------------------------------------------------ if (use_pflotran .and. pf_hmode) then - call Infiltration(bounds, num_hydrononsoic, filter_hydrononsoic, & - num_urbanc, filter_urbanc, atm2lnd_vars, ocn2lnd_vars, lnd2atm_vars, & - energyflux_vars, soilhydrology_vars, soilstate_vars, dtime) + call Infiltration(bounds, num_hydrononsoic, filter_hydrononsoic, & + num_urbanc, filter_urbanc, & + soilhydrology_vars, ocn2lnd_vars, soilstate_vars, dtime_mod) else !------------------------------------------------------------------------------------ - - call Infiltration(bounds, num_hydrologyc, filter_hydrologyc, & - num_urbanc, filter_urbanc, atm2lnd_vars, ocn2lnd_vars, lnd2atm_vars, & - energyflux_vars, soilhydrology_vars, soilstate_vars, dtime) - - !------------------------------------------------------------------------------------ + call Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filter_urbanc, & + soilhydrology_vars, ocn2lnd_vars, soilstate_vars, dtime_mod) end if !------------------------------------------------------------------------------------ !!TODO: need to fix the waterstate_vars dependence here. -#ifndef _OPENACC if (use_betr) then call ep_betr%BeTRSetBiophysForcing(bounds, col_pp, veg_pp, 1, nlevsoi, waterstate_vars=col_ws) call ep_betr%PreDiagSoilColWaterFlux(num_hydrologyc, filter_hydrologyc) endif -#endif if (use_vsfm) then call DrainageVSFM(bounds, num_hydrologyc, filter_hydrologyc, & num_urbanc, filter_urbanc,& - soilhydrology_vars, soilstate_vars, dtime) + soilhydrology_vars, soilstate_vars, dtime_mod) endif - call Compute_EffecRootFrac_And_VertTranSink(bounds, num_hydrologyc, & - filter_hydrologyc, soilstate_vars, canopystate_vars, energyflux_vars) + filter_hydrologyc, soilstate_vars, canopystate_vars) + if ( use_fan ) then ! save the h2osoi_liq in top layer before evaluating the soilwater movement call store_tsl_moisture(filter_hydrologyc, num_hydrologyc) end if -#ifndef _OPENACC ! If FATES plant hydraulics is turned on, over-ride default transpiration sink calculation if( use_fates ) call alm_fates%ComputeRootSoilFlux(bounds, num_hydrologyc, filter_hydrologyc, & soilstate_vars) -#endif !------------------------------------------------------------------------------------ if (use_pflotran .and. pf_hmode) then - - call SoilWater(bounds, num_hydrononsoic, filter_hydrononsoic, & - num_urbanc, filter_urbanc, & - soilhydrology_vars, soilstate_vars, dtime) + call SoilWater(bounds, num_hydrononsoic, filter_hydrononsoic, & + num_urbanc, filter_urbanc, & + soilhydrology_vars, soilstate_vars, dtime_mod) else !------------------------------------------------------------------------------------ - call SoilWater(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filter_urbanc, & - soilhydrology_vars, soilstate_vars, dtime) + soilhydrology_vars, soilstate_vars, dtime_mod) !------------------------------------------------------------------------------------ end if @@ -260,7 +249,6 @@ subroutine HydrologyNoDrainage(bounds, & call eval_tsl_moist_tend(filter_hydrologyc, num_hydrologyc) end if -#ifndef _OPENACC if (use_betr) then call ep_betr%BeTRSetBiophysForcing(bounds, col_pp, veg_pp, 1, nlevsoi, waterstate_vars=col_ws, & waterflux_vars=col_wf, soilhydrology_vars = soilhydrology_vars) @@ -269,7 +257,6 @@ subroutine HydrologyNoDrainage(bounds, & call ep_betr%RetrieveBiogeoFlux(bounds, 1, nlevsoi, waterflux_vars=col_wf) endif -#endif if (use_vichydro) then ! mapping soilmoist from CLM to VIC layers for runoff calculations @@ -280,28 +267,22 @@ subroutine HydrologyNoDrainage(bounds, & !------------------------------------------------------------------------------------ if (use_pflotran .and. pf_hmode) then - call WaterTable(bounds, num_hydrononsoic, filter_hydrononsoic, & - num_urbanc, filter_urbanc, & - soilhydrology_vars, soilstate_vars, dtime) + call WaterTable(bounds, num_hydrononsoic, filter_hydrononsoic, & + num_urbanc, filter_urbanc, & + soilhydrology_vars, soilstate_vars, dtime_mod) else - !------------------------------------------------------------------------------------ - + !------------------------------------------------------------------------------------ call WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filter_urbanc, & - soilhydrology_vars, soilstate_vars, dtime) - - !------------------------------------------------------------------------------------ + soilhydrology_vars, soilstate_vars, dtime_mod) + !------------------------------------------------------------------------------------ end if - !------------------------------------------------------------------------------------ - -#ifndef _OPENACC if (use_betr) then !apply dew and sublimation fluxes, this is a temporary work aroud for tracking water isotope !Jinyun Tang, Feb 4, 2015 call ep_betr%CalcDewSubFlux(bounds, col_pp, num_hydrologyc, filter_hydrologyc) endif -#endif if (use_firn_percolation_and_compaction) then call SnowCapping(bounds, num_nolakec, filter_nolakec, num_snowc, filter_snowc, & @@ -309,22 +290,24 @@ subroutine HydrologyNoDrainage(bounds, & end if ! Natural compaction and metamorphosis. - call SnowCompaction(bounds, num_snowc, filter_snowc, top_as, dtime) + call SnowCompaction(bounds, num_snowc, filter_snowc, top_as, dtime_mod) ! Combine thin snow elements call CombineSnowLayers(bounds, num_snowc, filter_snowc, & - aerosol_vars, dtime) + aerosol_vars, dtime_mod) ! Divide thick snow elements if (.not. use_extrasnowlayers) then call DivideSnowLayers(bounds, num_snowc, filter_snowc, & - aerosol_vars, is_lake=.false.) + aerosol_vars, is_lake=.false.) + else call DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & aerosol_vars, is_lake=.false.) endif ! Set empty snow layers to zero + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1,0 do fc = 1, num_snowc c = filter_snowc(fc) @@ -341,16 +324,18 @@ subroutine HydrologyNoDrainage(bounds, & ! Build new snow filter - call BuildSnowFilter(bounds, num_nolakec, filter_nolakec, & + call BuildSnowFilter(num_nolakec, filter_nolakec, & num_snowc, filter_snowc, num_nosnowc, filter_nosnowc) ! For columns where snow exists, accumulate 'time-covered-by-snow' counters. ! Otherwise, re-zero counter, since it is bareland + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) - snow_persistence(c) = snow_persistence(c) + dtime + snow_persistence(c) = snow_persistence(c) + dtime_mod end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nosnowc c = filter_nosnowc(fc) snow_persistence(c) = 0._r8 @@ -358,24 +343,28 @@ subroutine HydrologyNoDrainage(bounds, & ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice ! over all snow layers for history output - do fc = 1, num_nolakec c = filter_nolakec(fc) snowice(c) = 0._r8 snowliq(c) = 0._r8 end do - - do j = -nlevsno+1, 0 - do fc = 1, num_snowc - c = filter_snowc(fc) + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fc = 1, num_snowc + c = filter_snowc(fc) + sum1 = 0._r8; sum2 = 0._r8; + !$acc loop vector reduction(+:sum1,sum2) + do j = -nlevsno+1, 0 if (j >= snl(c)+1) then - snowice(c) = snowice(c) + h2osoi_ice(c,j) - snowliq(c) = snowliq(c) + h2osoi_liq(c,j) + sum1 = sum1 + h2osoi_ice(c,j) + sum2 = sum2 + h2osoi_liq(c,j) end if end do + snowice(c) = sum1 + snowliq(c) = sum2 end do ! Calculate column average snow depth + !$acc parallel loop independent gang vector default(present) do c = bounds%begc,bounds%endc snowdp(c) = snow_depth(c) * frac_sno_eff(c) end do @@ -383,54 +372,51 @@ subroutine HydrologyNoDrainage(bounds, & ! Determine ground temperature, ending water balance and volumetric soil water ! Calculate soil temperature and total water (liq+ice) in top 10cm of soil ! Calculate soil temperature and total water (liq+ice) in top 17cm of soil + + !NOTE: Reductions in this Loop!!! + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) do fc = 1, num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) if (.not. lun_pp%urbpoi(l)) then - t_soi_10cm(c) = 0._r8 - tsoi17(c) = 0._r8 - h2osoi_liqice_10cm(c) = 0._r8 - end if - end do - do fc = 1, num_nolakec - c = filter_nolakec(fc) - nlevbed = nlev2bed(c) - do j = 1, nlevbed - l = col_pp%landunit(c) - if (.not. lun_pp%urbpoi(l)) then + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8 + nlevbed = nlev2bed(c) + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = 1, nlevbed ! soil T at top 17 cm added by F. Li and S. Levis if (zi(c,j) <= 0.17_r8) then fracl = 1._r8 - tsoi17(c) = tsoi17(c) + t_soisno(c,j)*dz(c,j)*fracl + sum1 = sum1 + t_soisno(c,j)*dz(c,j)*fracl else if (zi(c,j) > 0.17_r8 .and. zi(c,j-1) < 0.17_r8) then fracl = (0.17_r8 - zi(c,j-1))/dz(c,j) - tsoi17(c) = tsoi17(c) + t_soisno(c,j)*dz(c,j)*fracl + sum1 = sum1 + t_soisno(c,j)*dz(c,j)*fracl end if end if if (zi(c,j) <= 0.1_r8) then fracl = 1._r8 - t_soi_10cm(c) = t_soi_10cm(c) + t_soisno(c,j)*dz(c,j)*fracl - h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + & - (h2osoi_liq(c,j)+h2osoi_ice(c,j))* & - fracl + sum2 = sum2 + t_soisno(c,j)*dz(c,j)*fracl + sum3 = sum3 + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* fracl else if (zi(c,j) > 0.1_r8 .and. zi(c,j-1) < 0.1_r8) then fracl = (0.1_r8 - zi(c,j-1))/dz(c,j) - t_soi_10cm(c) = t_soi_10cm(c) + t_soisno(c,j)*dz(c,j)*fracl - h2osoi_liqice_10cm(c) = h2osoi_liqice_10cm(c) + & - (h2osoi_liq(c,j)+h2osoi_ice(c,j))* & - fracl + sum2 = sum2 + t_soisno(c,j)*dz(c,j)*fracl + sum3 = sum3 + (h2osoi_liq(c,j)+h2osoi_ice(c,j))* fracl end if end if - end if - end do + + end do + tsoi17(c) = sum1 + t_soi_10cm(c) = sum2 + h2osoi_liqice_10cm(c) = sum3 + end if end do - + ! TODO - if this block of code is moved out of here - the SoilHydrology ! will NOT effect t_grnd, t_grnd_u or t_grnd_r + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) @@ -457,6 +443,7 @@ subroutine HydrologyNoDrainage(bounds, & end do + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevgrnd do fc = 1, num_nolakec c = filter_nolakec(fc) @@ -472,11 +459,12 @@ subroutine HydrologyNoDrainage(bounds, & end if end do end do - + if ( (use_cn .or. use_fates) .and. & .not.(use_pflotran .and. pf_hmode) ) then ! Update soilpsi. ! ZMS: Note this could be merged with the following loop updating smp_l in the future. + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevgrnd do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) @@ -504,32 +492,34 @@ subroutine HydrologyNoDrainage(bounds, & ! Available soil water up to a depth of 0.05 m. ! Potentially available soil water (=whc) up to a depth of 0.05 m. ! Water content as fraction of whc up to a depth of 0.05 m. - + + !$acc parallel loop independent gang worker default(present) private(sum1, sum2, sum3,c) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - rwat(c) = 0._r8 - swat(c) = 0._r8 - rz(c) = 0._r8 - end do + sum1 = 0._r8; sum2 = 0.0_r8; + sum3 = 0.0_r8 - do j = 1, nlevgrnd - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - !if (z(c,j)+0.5_r8*dz(c,j) <= 0.5_r8) then + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = 1, nlevgrnd if (z(c,j)+0.5_r8*dz(c,j) <= 0.05_r8) then watdry = watsat(c,j) * (316230._r8/sucsat(c,j)) ** (-1._r8/bsw(c,j)) - rwat(c) = rwat(c) + (h2osoi_vol(c,j)-watdry) * dz(c,j) - swat(c) = swat(c) + (watsat(c,j) -watdry) * dz(c,j) - rz(c) = rz(c) + dz(c,j) + sum1 = sum1 + (h2osoi_vol(c,j)-watdry) * dz(c,j) + sum2 = sum2 + (watsat(c,j) -watdry) * dz(c,j) + sum3 = sum3 + dz(c,j) end if end do + rwat(fc) = sum1 + swat(fc) = sum2 + rz(fc) = sum3 + end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - if (rz(c) /= 0._r8) then - tsw = rwat(c)/rz(c) - stsw = swat(c)/rz(c) + if (rz(fc) /= 0._r8) then + tsw = rwat(fc)/rz(fc) + stsw = swat(fc)/rz(fc) else watdry = watsat(c,1) * (316230._r8/sucsat(c,1)) ** (-1._r8/bsw(c,1)) tsw = h2osoi_vol(c,1) - watdry @@ -538,23 +528,30 @@ subroutine HydrologyNoDrainage(bounds, & wf(c) = tsw/stsw end do - do j = 1, nlevgrnd - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fc = 1, num_hydrologyc + c = filter_hydrologyc(fc) + sum1 = 0._r8; sum2 = 0._r8; sum3=0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = 1, nlevgrnd if (z(c,j)+0.5_r8*dz(c,j) <= 0.17_r8) then watdry = watsat(c,j) * (316230._r8/sucsat(c,j)) ** (-1._r8/bsw(c,j)) - rwat(c) = rwat(c) + (h2osoi_vol(c,j)-watdry) * dz(c,j) - swat(c) = swat(c) + (watsat(c,j) -watdry) * dz(c,j) - rz(c) = rz(c) + dz(c,j) + sum1 = sum1 + (h2osoi_vol(c,j)-watdry) * dz(c,j) + sum2 = sum2 + (watsat(c,j) -watdry) * dz(c,j) + sum3 = sum3 + dz(c,j) end if end do + rwat(fc) = rwat(fc) + sum1 + swat(fc) = swat(fc) + sum2 + rz(fc) = rz(fc) + sum3 end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - if (rz(c) /= 0._r8) then - tsw = rwat(c)/rz(c) - stsw = swat(c)/rz(c) + if (rz(fc) /= 0._r8) then + tsw = rwat(fc)/rz(fc) + stsw = swat(fc)/rz(fc) else watdry = watsat(c,1) * (316230._r8/sucsat(c,1)) ** (-1._r8/bsw(c,1)) tsw = h2osoi_vol(c,1) - watdry @@ -565,12 +562,14 @@ subroutine HydrologyNoDrainage(bounds, & end if ! top-layer diagnostics + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) h2osno_top(c) = h2osoi_ice(c,snl(c)+1) + h2osoi_liq(c,snl(c)+1) enddo ! Zero variables in columns without snow + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nosnowc c = filter_nosnowc(fc) @@ -583,6 +582,15 @@ subroutine HydrologyNoDrainage(bounds, & sno_liq_top(c) = spval end do + !$acc exit data delete(& + !$acc rwat(:), & + !$acc swat(:), & + !$acc rz(:), & + !$acc psi, & + !$acc sum1, & + !$acc sum2, & + !$acc sum3) + end associate contains diff --git a/components/elm/src/biogeophys/LakeCon.F90 b/components/elm/src/biogeophys/LakeCon.F90 index 5ca5dc576e5d..bce8960535cd 100644 --- a/components/elm/src/biogeophys/LakeCon.F90 +++ b/components/elm/src/biogeophys/LakeCon.F90 @@ -2,7 +2,7 @@ module LakeCon !----------------------------------------------------------------------- ! !DESCRIPTION: - ! Module containing constants and parameters for the Lake code + ! Module containing constants and parameters for the Lake code ! (CLM4-LISSS, documented in Subin et al. 2011, JAMES) ! Also contains time constant variables for Lake code ! Created by Zack Subin, 2011 @@ -22,18 +22,18 @@ module LakeCon !----------------------------------------------------------------------- !------------------------------------------------------------------ - ! Lake Model non-tuneable constants + ! Lake Model non-tuneable constants !------------------------------------------------------------------ ! temperature of maximum water density (K) ! This is from Hostetler and Bartlein (1990); more updated sources suggest 277.13 K. - real(r8), parameter :: tdmax = 277._r8 + real(r8), parameter :: tdmax = 277._r8 !------------------------------------------------------------------ - ! Lake Model tuneable constants + ! Lake Model tuneable constants !------------------------------------------------------------------ - ! lake emissivity. This is used for both frozen and unfrozen lakes. + ! lake emissivity. This is used for both frozen and unfrozen lakes. ! This is pulled in from CLM4 and the reference is unclear. real(r8), parameter :: emg_lake = 0.97_r8 @@ -41,15 +41,15 @@ module LakeCon ! absorbed in ~1 m of water (the surface layer za_lake). ! This is roughly the fraction over 700 nm but may depend on the details ! of atmospheric radiative transfer. As long as NIR = 700 nm and up, this can be zero. - real(r8) :: betavis = 0.0_r8 + real(r8) :: betavis = 0.0_r8 ! Momentum Roughness length over frozen lakes without snow (m) ! Typical value found in the literature, and consistent with Mironov expressions. ! See e.g. Morris EM 1989, Andreas EL 1987, Guest & Davidson 1991 (as cited in Vavrus 1996) - real(r8), parameter :: z0frzlake = 0.001_r8 + real(r8), parameter :: z0frzlake = 0.001_r8 ! Base of surface light absorption layer for lakes (m) - real(r8), parameter :: za_lake = 0.6_r8 + real(r8), parameter :: za_lake = 0.6_r8 ! For calculating prognostic roughness length real(r8), parameter :: cur0 = 0.01_r8 ! min. Charnock parameter @@ -94,7 +94,7 @@ module LakeCon ! true => use old fcrit & minz0 as per Subin et al 2011 form ! See initLakeMod for details. Difference is very small for ! small lakes and negligible for large lakes. Currently hardwired off. - logical, public :: lake_use_old_fcrit_minz0 = .false. + logical, public :: lake_use_old_fcrit_minz0 = .false. ! used in LakeTemperature ! Increase mixing by a large factor for deep lakes @@ -102,10 +102,10 @@ module LakeCon ! See Subin et al 2011 (JAMES) for details ! (m) minimum lake depth to invoke deepmixing - real(r8), public :: deepmixing_depthcrit = 25._r8 + real(r8), public :: deepmixing_depthcrit = 25._r8 ! factor to increase mixing by - real(r8), public :: deepmixing_mixfact = 10._r8 + real(r8), public :: deepmixing_mixfact = 10._r8 ! true => Suppress enhanced diffusion. Small differences. ! Currently hardwired .false. @@ -113,19 +113,30 @@ module LakeCon ! Enhanced diffusion is intended for under ice and at large depths. ! It is a much smaller change on its own than the "deepmixing" ! above, but it increases the effect of deepmixing under ice and for large depths. - logical, public :: lake_no_ed = .false. + logical, public :: lake_no_ed = .false. ! puddling (not extensively tested and currently hardwired off) ! used in LakeTemperature and SurfaceAlbedo ! true => suppress convection when greater than minimum amount ! of ice is present. This also effectively sets lake_no_melt_icealb. - logical, public :: lakepuddling = .false. + logical, public :: lakepuddling = .false. ! (m) minimum amount of total ice nominal thickness before ! convection is suppressed - real(r8), public :: lake_puddle_thick = 0.2_r8 + real(r8), public :: lake_puddle_thick = 0.2_r8 !----------------------------------------------------------------------- + !$acc declare create(betavis) + !$acc declare create(fcrit ) + !$acc declare create(minz0lake ) + !$acc declare create(lsadz) + !$acc declare create(pudz) + !$acc declare create(depthcrit) + !$acc declare create(mixfact) + !$acc declare create(lake_use_old_fcrit_minz0) + !$acc declare create(lakepuddling) + !$acc declare create(lake_puddle_thick) + !$acc declare create(lake_no_ed) contains @@ -133,7 +144,7 @@ module LakeCon subroutine LakeConInit() ! ! !DESCRIPTION: - ! Initialize time invariant variables for S Lake code + ! Initialize time invariant variables for S Lake code !------------------------------------------------------------------------ if (masterproc) write (iulog,*) 'Attempting to initialize time invariant variables for lakes' @@ -142,18 +153,18 @@ subroutine LakeConInit() if (lake_use_old_fcrit_minz0) then ! critical dimensionless fetch for Charnock parameter. From Vickers & Mahrt 1997 ! but converted to use u instead of u* (Form used in Subin et al. 2011) - fcrit = 22._r8 + fcrit = 22._r8 ! (m) Minimum allowed roughness length for unfrozen lakes. ! (Used in Subin et al. 2011) - minz0lake = 1.e-5_r8 + minz0lake = 1.e-5_r8 else ! Vickers & Mahrt 1997 - fcrit = 100._r8 + fcrit = 100._r8 ! (m) Minimum allowed roughness length for unfrozen lakes. ! Now set low so it is only to avoid floating point exceptions. - minz0lake = 1.e-10_r8 + minz0lake = 1.e-10_r8 end if if (lakepuddling) then @@ -161,15 +172,15 @@ subroutine LakeConInit() ! This option has not been extensively tested. ! This option turns on lake_no_melt_icealb, as the decrease in albedo will be based ! on whether there is water over nice, not purely a function of ice top temperature. - pudz = lake_puddle_thick + pudz = lake_puddle_thick end if ! (m) Depth beneath which to increase mixing. See discussion in Subin et al. 2011 - depthcrit = deepmixing_depthcrit + depthcrit = deepmixing_depthcrit ! Mixing increase factor. ! Defaults are 25 m, increase by 10. ! Note some other namelists will be used directly in lake physics during model integration. - mixfact = deepmixing_mixfact + mixfact = deepmixing_mixfact if (masterproc) write (iulog,*) 'Successfully initialized time invariant variables for lakes' diff --git a/components/elm/src/biogeophys/LakeHydrologyMod.F90 b/components/elm/src/biogeophys/LakeHydrologyMod.F90 index b11a1a93f57b..0d914b401216 100644 --- a/components/elm/src/biogeophys/LakeHydrologyMod.F90 +++ b/components/elm/src/biogeophys/LakeHydrologyMod.F90 @@ -26,7 +26,6 @@ module LakeHydrologyMod use VegetationDataType , only : veg_ef, veg_wf use atm2lndType , only : atm2lnd_type use AerosolType , only : aerosol_type - use EnergyFluxType , only : energyflux_type use FrictionVelocityType , only : frictionvel_type use LakeStateType , only : lakestate_type use SoilStateType , only : soilstate_type @@ -50,7 +49,7 @@ subroutine LakeHydrology(bounds, & num_lakec, filter_lakec, num_lakep, filter_lakep, & num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc, & atm2lnd_vars, soilstate_vars, & - energyflux_vars, aerosol_vars, lakestate_vars) + aerosol_vars, lakestate_vars) ! ! !DESCRIPTION: ! WARNING: This subroutine assumes lake columns have one and only one pft. @@ -71,7 +70,6 @@ subroutine LakeHydrology(bounds, & ! Cleanup and do water balance. ! ! !USES: - !$acc routine seq use elm_varcon , only : denh2o, denice, spval, hfus, tfrz, cpliq, cpice use elm_varpar , only : nlevsno, nlevgrnd, nlevsoi use elm_varctl , only : iulog, use_extrasnowlayers, use_lake_wat_storage, use_firn_percolation_and_compaction @@ -79,6 +77,7 @@ subroutine LakeHydrology(bounds, & use SnowHydrologyMod, only : SnowCompaction, CombineSnowLayers, SnowWater, BuildSnowFilter use SnowHydrologyMod, only : DivideSnowLayers, DivideExtraSnowLayers, SnowCapping use LakeCon , only : lsadz + use abortutils , only : endrun ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds @@ -92,32 +91,26 @@ subroutine LakeHydrology(bounds, & integer , intent(out) :: filter_shlakenosnowc(:) ! column filter for non-snow points type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(soilstate_type) , intent(in) :: soilstate_vars - type(energyflux_type) , intent(inout) :: energyflux_vars type(aerosol_type) , intent(inout) :: aerosol_vars type(lakestate_type) , intent(inout) :: lakestate_vars - real(r8) :: dtime ! land model time step (sec) - ! ! !LOCAL VARIABLES: integer :: p,fp,g,t,l,c,j,fc,jtop ! indices integer :: newnode ! flag when new snow node is set, (1=yes, 0=no) real(r8) :: dz_snowf ! layer thickness rate change due to precipitation [mm/s] real(r8) :: bifall ! bulk density of newly fallen dry snow [kg/m3] - real(r8) :: fracsnow(bounds%begp:bounds%endp) ! frac of precipitation that is snow - real(r8) :: fracrain(bounds%begp:bounds%endp) ! frac of precipitation that is rain - real(r8) :: qflx_prec_grnd_snow(bounds%begp:bounds%endp) ! snow precipitation incident on ground [mm/s] - real(r8) :: qflx_prec_grnd_rain(bounds%begp:bounds%endp) ! rain precipitation incident on ground [mm/s] real(r8) :: qflx_evap_soi_lim ! temporary evap_soi limited by top snow layer content [mm/s] real(r8) :: qflx_snwcp ! temporary snow cap flux real(r8) :: h2osno_temp ! temporary h2osno [kg/m^2] - real(r8) :: sumsnowice(bounds%begc:bounds%endc) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] - logical :: unfrozen(bounds%begc:bounds%endc) ! true if top lake layer is unfrozen with snow layers above + real(r8) :: sumsnowice(1:num_lakec) ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2] + logical :: unfrozen(1:num_lakec) ! true if top lake layer is unfrozen with snow layers above real(r8) :: heatrem ! used in case above [J/m^2] - real(r8) :: heatsum(bounds%begc:bounds%endc) ! used in case above [J/m^2] + real(r8) :: heatsum(1:num_lakec) ! used in case above [J/m^2] 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 real(r8), parameter :: snow_bd = 250._r8 ! assumed snow bulk density (for lakes w/out resolved snow layers) [kg/m^3] ! Should only be used for frost below. + real(r8) :: sum1, sum2, sum3, sum4 !----------------------------------------------------------------------- associate( & @@ -220,22 +213,35 @@ subroutine LakeHydrology(bounds, & begc => bounds%begc, & endc => bounds%endc & ) - - ! Determine step size - - dtime = dtime_mod + !$acc enter data create(& + !$acc sumsnowice(:), & + !$acc unfrozen(:), & + !$acc heatsum(:), & + !$acc sum1, & + !$acc sum2, & + !$acc sum3 ) + ! Add soil water to water balance. - do j = 1, nlevgrnd - do fc = 1, num_lakec - c = filter_lakec(fc) - begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + h2osoi_liq(c,j) - h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + h2osoi_ice(c,j) + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = 1, nlevgrnd + sum1 = sum1 + h2osoi_ice(c,j) + h2osoi_liq(c,j) + sum2 = sum2 + h2osoi_liq(c,j) + sum3 = sum3 + h2osoi_ice(c,j) end do + begwb(c) = begwb(c) + sum1 + h2osoi_liq_depth_intg(c) = h2osoi_liq_depth_intg(c) + sum2 + h2osoi_ice_depth_intg(c) = h2osoi_ice_depth_intg(c) + sum3 end do ! Add lake water storage to water balance. if (use_lake_wat_storage) then + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) begwb(c) = begwb(c) + wslake(c) @@ -245,42 +251,42 @@ subroutine LakeHydrology(bounds, & !!!!!!!!!!!!!!!!!!!!!!!!!!! ! Do precipitation onto ground, etc., from CanopyHydrology - + !$acc parallel loop independent gang vector default(present) do fp = 1, num_lakep p = filter_lakep(fp) c = pcolumn(p) t = ptopounit(p) - qflx_prec_grnd_snow(p) = forc_snow(t) - qflx_prec_grnd_rain(p) = forc_rain(t) - qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p) + ! qflx_prec_grnd_snow(p) = forc_snow(t) + ! qflx_prec_grnd_rain = forc_rain(t) + qflx_prec_grnd(p) = forc_snow(t) + forc_rain(t) qflx_dirct_rain(p) = 0._r8 qflx_leafdrip(p) = 0._r8 if (.not. use_firn_percolation_and_compaction) then if (do_capsnow(c)) then - qflx_snwcp_ice(p) = qflx_prec_grnd_snow(p) - qflx_snwcp_liq(p) = qflx_prec_grnd_rain(p) + qflx_snwcp_ice(p) = forc_snow(t) + qflx_snwcp_liq(p) = forc_rain(t) qflx_snow_grnd_patch(p) = 0._r8 qflx_rain_grnd(p) = 0._r8 else qflx_snwcp_ice(p) = 0._r8 qflx_snwcp_liq(p) = 0._r8 - qflx_snow_grnd_patch(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) - qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) + qflx_snow_grnd_patch(p) = forc_snow(t) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = forc_rain(t) ! liquid water onto ground (mm/s) end if else - qflx_snow_grnd_patch(p) = qflx_prec_grnd_snow(p) ! ice onto ground (mm/s) - qflx_rain_grnd(p) = qflx_prec_grnd_rain(p) ! liquid water onto ground (mm/s) + qflx_snow_grnd_patch(p) = forc_snow(t) ! ice onto ground (mm/s) + qflx_rain_grnd(p) = forc_rain(t) ! liquid water onto ground (mm/s) end if ! Assuming one PFT; needed for below qflx_snow_grnd_col(c) = qflx_snow_grnd_patch(p) qflx_rain_grnd_col(c) = qflx_rain_grnd(p) end do ! (end pft loop) - + ! Determine snow height and snow water - + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) t = col_pp%topounit(c) @@ -300,8 +306,8 @@ subroutine LakeHydrology(bounds, & bifall=50._r8 end if dz_snowf = qflx_snow_grnd_col(c)/bifall - snow_depth(c) = snow_depth(c) + dz_snowf*dtime - h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime ! snow water equivalent (mm) + snow_depth(c) = snow_depth(c) + dz_snowf*dtime_mod + h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime_mod ! snow water equivalent (mm) end if ! When the snow accumulation exceeds 40 mm, initialize snow layer @@ -322,25 +328,26 @@ subroutine LakeHydrology(bounds, & ! intitialize SNICAR variables for fresh snow: !call aerosol_vars%Reset(column=c) - aerosol_vars%mss_bcpho_col(c,:) = 0._r8 - aerosol_vars%mss_bcphi_col(c,:) = 0._r8 - aerosol_vars%mss_bctot_col(c,:) = 0._r8 aerosol_vars%mss_bc_col_col(c) = 0._r8 aerosol_vars%mss_bc_top_col(c) = 0._r8 - - aerosol_vars%mss_ocpho_col(c,:) = 0._r8 - aerosol_vars%mss_ocphi_col(c,:) = 0._r8 - aerosol_vars%mss_octot_col(c,:) = 0._r8 aerosol_vars%mss_oc_col_col(c) = 0._r8 aerosol_vars%mss_oc_top_col(c) = 0._r8 - - aerosol_vars%mss_dst1_col(c,:) = 0._r8 - aerosol_vars%mss_dst2_col(c,:) = 0._r8 - aerosol_vars%mss_dst3_col(c,:) = 0._r8 - aerosol_vars%mss_dst4_col(c,:) = 0._r8 - aerosol_vars%mss_dsttot_col(c,:) = 0._r8 aerosol_vars%mss_dst_col_col(c) = 0._r8 aerosol_vars%mss_dst_top_col(c) = 0._r8 + + ! do j = -nlevsno+1,0 + aerosol_vars%mss_bcpho_col(c,:) = 0._r8 + aerosol_vars%mss_bcphi_col(c,:) = 0._r8 + aerosol_vars%mss_bctot_col(c,:) = 0._r8 + aerosol_vars%mss_ocpho_col(c,:) = 0._r8 + aerosol_vars%mss_ocphi_col(c,:) = 0._r8 + aerosol_vars%mss_octot_col(c,:) = 0._r8 + aerosol_vars%mss_dst1_col(c,:) = 0._r8 + aerosol_vars%mss_dst2_col(c,:) = 0._r8 + aerosol_vars%mss_dst3_col(c,:) = 0._r8 + aerosol_vars%mss_dst4_col(c,:) = 0._r8 + aerosol_vars%mss_dsttot_col(c,:) = 0._r8 + ! end do ! call waterstate_vars%Reset(column=c) col_ws%snw_rds(c,0) = snw_rds_min @@ -351,14 +358,14 @@ subroutine LakeHydrology(bounds, & ! later. if (snl(c) < 0 .and. newnode == 0) then - h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c) - dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime + h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime_mod*qflx_snow_grnd_col(c) + dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime_mod end if end do ! Calculate sublimation and dew, adapted from HydrologyLake and Biogeophysics2. - + !$acc parallel loop independent gang vector default(present) do fp = 1,num_lakep p = filter_lakep(fp) c = pcolumn(p) @@ -379,7 +386,7 @@ subroutine LakeHydrology(bounds, & ! use the ratio of liquid to (liquid+ice) in the top layer to determine split ! Since we're not limiting evap over lakes, but still can't remove more from top ! snow layer than there is there, create temp. limited evap_soi. - qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime) + qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime_mod) if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._r8) then qflx_evap_grnd(p) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._r8) else @@ -410,7 +417,7 @@ subroutine LakeHydrology(bounds, & if (qflx_evap_soi(p) >= 0._r8) then ! Sublimation: do not allow for more sublimation than there is snow ! after melt. Remaining surface evaporation used for infiltration. - qflx_sub_snow(p) = min(qflx_evap_soi(p), h2osno(c)/dtime) + qflx_sub_snow(p) = min(qflx_evap_soi(p), h2osno(c)/dtime_mod) qflx_evap_grnd(p) = qflx_evap_soi(p) - qflx_sub_snow(p) else if (t_grnd(c) < tfrz-0.1_r8) then @@ -424,11 +431,9 @@ subroutine LakeHydrology(bounds, & h2osno_temp = h2osno(c) if (do_capsnow(c) .and. .not. use_firn_percolation_and_compaction) then - h2osno(c) = h2osno(c) - qflx_sub_snow(p)*dtime + h2osno(c) = h2osno(c) - qflx_sub_snow(p)*dtime_mod qflx_snwcp_ice(p) = qflx_snwcp_ice(p) + qflx_dew_snow(p) qflx_snwcp_liq(p) = qflx_snwcp_liq(p) + qflx_dew_grnd(p) - else - h2osno(c) = h2osno(c) + (-qflx_sub_snow(p)+qflx_dew_snow(p))*dtime end if h2osno(c) = max(h2osno(c), 0._r8) if (h2osno_temp > 0._r8) then @@ -444,11 +449,40 @@ subroutine LakeHydrology(bounds, & end if end do + !$acc parallel loop independent gang worker default(present) private(sum1,jtop,h2osno_temp) + do fc = 1, num_lakec + c = filter_lakec(fc) + jtop = snl(c)+1 + + sum1 = h2osno(c) + if(jtop > 0) then + h2osno_temp = h2osno(c) + + !$acc loop vector reduction(+:sum1) + do p = col_pp%pfti(c), col_pp%pftf(c) + if(veg_pp%active(p)) then + if (do_capsnow(c) .and. .not. use_extrasnowlayers) then + sum1 = sum1 - qflx_sub_snow(p)*dtime_mod + else + sum1 = sum1 + (-qflx_sub_snow(p)+qflx_dew_snow(p))*dtime_mod + end if + end if + end do + h2osno(c) = sum1 + if (h2osno_temp > 0._r8) then + snow_depth(c) = snow_depth(c) * h2osno(c) / h2osno_temp + else + snow_depth(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250. + end if + h2osno(c) = max(h2osno(c), 0._r8) + end if + end do ! patch averages must be done here -- BEFORE SNOW CALCULATIONS AS THEY USE IT. ! for output to history tape and other uses ! (note that pft2col is called before LakeHydrology, so we can't use that routine ! to do these column -> pft averages) + !$acc parallel loop independent gang vector default(present) do fp = 1,num_lakep p = filter_lakep(fp) c = pcolumn(p) @@ -467,10 +501,11 @@ subroutine LakeHydrology(bounds, & ! Determine initial snow/no-snow filters (will be modified possibly by ! routines CombineSnowLayers and DivideSnowLayers below) - call BuildSnowFilter(bounds, num_lakec, filter_lakec, & + call BuildSnowFilter( num_lakec, filter_lakec, & num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) ! specify snow fraction + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) if (h2osno(c) > 0.0_r8) then @@ -496,8 +531,9 @@ subroutine LakeHydrology(bounds, & ! pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the ! saturation value, then remove water. + ! changed to nlevsoi on 8/11/10 to make consistent with non-lake bedrock + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1,nlevsoi !nlevgrnd - ! changed to nlevsoi on 8/11/10 to make consistent with non-lake bedrock do fc = 1, num_lakec c = filter_lakec(fc) @@ -533,12 +569,12 @@ subroutine LakeHydrology(bounds, & ! Natural compaction and metamorphosis. - call SnowCompaction(bounds, num_shlakesnowc, filter_shlakesnowc,top_as, dtime) + call SnowCompaction(bounds, num_shlakesnowc, filter_shlakesnowc,top_as, dtime_mod) ! Combine thin snow elements call CombineSnowLayers(bounds, num_shlakesnowc, filter_shlakesnowc, & - aerosol_vars, dtime) + aerosol_vars, dtime_mod) ! Divide thick snow elements if (.not. use_extrasnowlayers) then @@ -554,6 +590,7 @@ subroutine LakeHydrology(bounds, & ! excessive because the fluxes were calculated with a fixed ground temperature of freezing, but the ! phase change was unable to restore the temperature to freezing. + !$acc parallel loop independent gang vector default(present) do fp = 1, num_lakep p = filter_lakep(fp) c = pcolumn(p) @@ -564,12 +601,12 @@ subroutine LakeHydrology(bounds, & ! Remove layer ! Take extra heat of layer and release to sensible heat in order to maintain energy conservation. heatrem = cpliq*h2osoi_liq(c,j)*(t_soisno(c,j) - tfrz) - eflx_sh_tot(p) = eflx_sh_tot(p) + heatrem/dtime - eflx_sh_grnd(p) = eflx_sh_grnd(p) + heatrem/dtime ! Added this line 7/22/11 for consistency. - eflx_soil_grnd(p) = eflx_soil_grnd(p) - heatrem/dtime - eflx_gnet(p) = eflx_gnet(p) - heatrem/dtime + eflx_sh_tot(p) = eflx_sh_tot(p) + heatrem/dtime_mod + eflx_sh_grnd(p) = eflx_sh_grnd(p) + heatrem/dtime_mod ! Added this line 7/22/11 for consistency. + eflx_soil_grnd(p) = eflx_soil_grnd(p) - heatrem/dtime_mod + eflx_gnet(p) = eflx_gnet(p) - heatrem/dtime_mod - eflx_grnd_lake(p) = eflx_gnet(p) - heatrem/dtime + eflx_grnd_lake(p) = eflx_gnet(p) - heatrem/dtime_mod qflx_sl_top_soil(c) = qflx_sl_top_soil(c) + h2osno(c) snl(c) = 0 h2osno(c) = 0._r8 @@ -585,48 +622,49 @@ subroutine LakeHydrology(bounds, & ! sufficient heat to melt the snow without freezing, then that will be done. ! Otherwise, the top layer will undergo freezing, but only if the top layer will ! not freeze completely. Otherwise, let the snow layers persist and melt by diffusion. - + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._r8 .and. snl(c) < 0) then - unfrozen(c) = .true. + unfrozen(fc) = .true. else - unfrozen(c) = .false. + unfrozen(fc) = .false. end if end do - do j = -nlevsno+1,0 - do fc = 1, num_lakec - c = filter_lakec(fc) + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fc = 1, num_lakec + c = filter_lakec(fc) - if (unfrozen(c)) then - if (j == -nlevsno+1) then - sumsnowice(c) = 0._r8 - heatsum(c) = 0._r8 - end if + if (unfrozen(fc)) then + sum1 = 0._r8 + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2) + do j = -nlevsno+1,0 if (j >= snl(c)+1) then - sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j) - heatsum(c) = heatsum(c) + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) & + sum1 = sum1 + h2osoi_ice(c,j) + sum2 = sum2 + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) & + h2osoi_liq(c,j)*cpliq*(tfrz - t_soisno(c,j)) end if - end if - end do + end do + sumsnowice(fc) = sum1 + heatsum(fc) = sum2 + end if end do - + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) - - if (unfrozen(c)) then - heatsum(c) = heatsum(c) + sumsnowice(c)*hfus - heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c) + g = col_pp%gridcell(c) ! DEBUG + if (unfrozen(fc)) then + heatsum(fc) = heatsum(fc) + sumsnowice(fc)*hfus + heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(fc) if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._r8) then ! Remove snow and subtract the latent heat from the top layer. - qflx_snomelt(c) = qflx_snomelt(c) + h2osno(c)/dtime - - eflx_snomelt(c) = eflx_snomelt(c) + h2osno(c)*hfus/dtime + qflx_snomelt(c) = qflx_snomelt(c) + h2osno(c)/dtime_mod + eflx_snomelt(c) = eflx_snomelt(c) + h2osno(c)*hfus/dtime_mod ! update snow melt for this case qflx_snow_melt(c) = qflx_snow_melt(c) + qflx_snomelt(c) @@ -647,7 +685,7 @@ subroutine LakeHydrology(bounds, & end do ! Set empty snow layers to zero - + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1,0 do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) @@ -664,49 +702,63 @@ subroutine LakeHydrology(bounds, & ! Build new snow filter - call BuildSnowFilter(bounds, num_lakec, filter_lakec, & + call BuildSnowFilter(num_lakec, filter_lakec, & num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) - - ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice - ! over all snow layers for history output - + do fc = 1, num_lakec c = filter_lakec(fc) snowice(c) = 0._r8 snowliq(c) = 0._r8 end do - do j = -nlevsno+1, 0 - do fc = 1, num_shlakesnowc - c = filter_shlakesnowc(fc) + ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice + ! over all snow layers for history output + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fc = 1, num_shlakesnowc + c = filter_shlakesnowc(fc) + sum1 = 0._r8; + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2) + do j = -nlevsno+1, 0 if (j >= snl(c)+1) then - snowice(c) = snowice(c) + h2osoi_ice(c,j) - snowliq(c) = snowliq(c) + h2osoi_liq(c,j) + sum1 = sum1 + h2osoi_ice(c,j) + sum2 = sum2 + h2osoi_liq(c,j) end if end do + snowice(c) = sum1 + snowliq(c) = sum2 end do ! Determine ending water balance and volumetric soil water - + !$acc parallel loop independent gang worker default(present) private(sum1) do fc = 1, num_lakec c = filter_lakec(fc) - endwb(c) = h2osno(c) + sum1 = h2osno(c) + !$acc loop vector reduction(+:sum1) + do j = 1, nlevgrnd + sum1 = sum1 + h2osoi_ice(c,j) + h2osoi_liq(c,j) + end do + endwb(c) = sum1 end do + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevgrnd do fc = 1, num_lakec c = filter_lakec(fc) - endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice) end do end do - - do fp = 1,num_lakep - p = filter_lakep(fp) - c = pcolumn(p) - t = ptopounit(p) - g = pgridcell(p) - + + !NOTE: Need to resolve the race condition here. + ! Is it important to go through lake patches sequentially + ! for water storage? + ! Currently num_lakec = num_lakep all timesteps? + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_lakec + c = filter_lakec(fc) + g = col_pp%gridcell(c) + t = col_pp%topounit(c) + qflx_drain_perched(c) = 0._r8 qflx_h2osfc_surf(c) = 0._r8 qflx_rsub_sat(c) = 0._r8 @@ -717,9 +769,29 @@ subroutine LakeHydrology(bounds, & qflx_irrig(p) = 0._r8 qflx_irrig_col(c) = 0._r8 - ! Insure water balance using qflx_qrgwl - if (use_lake_wat_storage) then + qflx_floodc(c) = qflx_floodg(g) + qflx_top_soil(c) = forc_rain(t) + qflx_snomelt(c) + + end do + + if(num_lakep .ne. num_lakec) then + write(iulog,*) "num_lakep != num_lakec - may be race condition" + call endrun("LakeHydrology") + end if + + if(use_lake_wat_storage) then + !$acc parallel loop independent gang vector default(present) + do fp = 1, num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + g = cgridcell(c) + t = col_pp%topounit(c) + + qflx_irrig(p) = 0._r8 + + ! Insure water balance using qflx_qrgwl qflx_qrgwl(c) = 0._r8 + if (wslake(c) >= 5000._r8) then if (.not. use_firn_percolation_and_compaction) then qflx_snwcp = qflx_snwcp_ice(p) @@ -727,34 +799,45 @@ subroutine LakeHydrology(bounds, & qflx_snwcp = qflx_snwcp_ice_col(c) end if qflx_qrgwl(c) = forc_rain(t) + forc_snow(t) - qflx_evap_tot(p) - qflx_snwcp + & - qflx_floodg(g) - (endwb(c) + wslake(c) -begwb(c))/dtime + qflx_floodg(g) - (endwb(c) + wslake(c) -begwb(c))/dtime_mod end if wslake(c) = (forc_rain(t) + forc_snow(t) - qflx_evap_tot(p) - & - qflx_snwcp_ice(p) + qflx_floodg(g) - qflx_qrgwl(c)) * dtime - & + qflx_snwcp_ice(p) + qflx_floodg(g) - qflx_qrgwl(c)) * dtime_mod - & (endwb(c) - begwb(c)) endwb(c) = endwb(c) + wslake(c) - else + end do + else + !$acc parallel loop independent gang vector default(present) + do fp = 1,num_lakep + p = filter_lakep(fp) + c = pcolumn(p) + t = ptopounit(p) + g = pgridcell(p) + + qflx_irrig(p) = 0._r8 + + ! Insure water balance using qflx_qrgwl if (.not. use_firn_percolation_and_compaction) then qflx_snwcp = qflx_snwcp_ice(p) else qflx_snwcp = qflx_snwcp_ice_col(c) end if qflx_qrgwl(c) = forc_rain(t) + forc_snow(t) - qflx_evap_tot(p) - qflx_snwcp - & - (endwb(c)-begwb(c))/dtime + qflx_floodg(g) - end if + (endwb(c)-begwb(c))/dtime_mod + qflx_floodg(g) + qflx_runoff(c) = qflx_drain(c) + qflx_qrgwl(c) + enddo - qflx_floodc(c) = qflx_floodg(g) - qflx_runoff(c) = qflx_drain(c) + qflx_qrgwl(c) - qflx_top_soil(c) = qflx_prec_grnd_rain(p) + qflx_snomelt(c) - enddo + end if ! top-layer diagnostics + !$acc parallel loop independent gang vector default(present) do fc = 1, num_shlakesnowc c = filter_shlakesnowc(fc) h2osno_top(c) = h2osoi_ice(c,snl(c)+1) + h2osoi_liq(c,snl(c)+1) end do ! Zero variables in columns without snow + !$acc parallel loop independent gang vector default(present) do fc = 1, num_shlakenosnowc c = filter_shlakenosnowc(fc) @@ -767,6 +850,13 @@ subroutine LakeHydrology(bounds, & sno_liq_top(c) = spval end do + !$acc exit data delete(& + !$acc sumsnowice(:), & + !$acc unfrozen(:), & + !$acc heatsum(:), & + !$acc sum1, & + !$acc sum2, sum3) + end associate end subroutine LakeHydrology diff --git a/components/elm/src/biogeophys/LakeTemperatureMod.F90 b/components/elm/src/biogeophys/LakeTemperatureMod.F90 index f17a4a32a18e..7a819b7e263e 100644 --- a/components/elm/src/biogeophys/LakeTemperatureMod.F90 +++ b/components/elm/src/biogeophys/LakeTemperatureMod.F90 @@ -1,7 +1,5 @@ module LakeTemperatureMod -#include "shr_assert.h" - !----------------------------------------------------------------------- ! !DESCRIPTION: ! Calculates surface fluxes and temperature for lakes. @@ -12,7 +10,6 @@ module LakeTemperatureMod use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type use CH4Mod , only : ch4_type - use EnergyFluxType , only : energyflux_type use LakeStateType , only : lakestate_type use SoilStateType , only : soilstate_type use SolarAbsorbedType , only : solarabs_type @@ -41,7 +38,7 @@ module LakeTemperatureMod !----------------------------------------------------------------------- subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_lakep, & solarabs_vars, soilstate_vars, ch4_vars, & - energyflux_vars, lakestate_vars) + lakestate_vars) ! ! !DESCRIPTION: ! Calculates temperatures in the 25-45 layer column of (possible) snow, @@ -107,7 +104,6 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! and dump small imbalance into sensible heat, or pass large errors to BalanceCheckMod for abort. ! ! !USES: - !$acc routine seq use LakeCon , only : betavis, za_lake, n2min, tdmax, pudz, depthcrit, mixfact use LakeCon , only : lakepuddling, lake_no_ed use QSatMod , only : QSat @@ -126,14 +122,12 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la type(solarabs_type) , intent(in) :: solarabs_vars type(soilstate_type) , intent(in) :: soilstate_vars type(ch4_type) , intent(inout) :: ch4_vars - type(energyflux_type) , intent(inout) :: energyflux_vars type(lakestate_type) , intent(inout) :: lakestate_vars - real(r8) :: dtime ! ! !LOCAL VARIABLES: real(r8), parameter :: p0 = 1._r8 ! neutral value of turbulent prandtl number integer :: i,j,fc,fp,g,c,p ! do loop or array index - real(r8) :: beta(bounds%begc:bounds%endc) ! fraction of solar rad absorbed at surface: equal to NIR fraction + ! real(r8) :: beta(1:num_lakec) ! fraction of solar rad absorbed at surface: equal to NIR fraction ! of surface absorbed shortwave real(r8) :: eta ! light extinction coefficient (/m): depends on lake type real(r8) :: cwat ! specific heat capacity of water (j/m**3/kelvin) @@ -143,83 +137,84 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! using water density as above real(r8) :: km ! molecular diffusion coefficient (m**2/s) real(r8) :: tkice_eff ! effective conductivity since layer depth is constant - real(r8) :: a(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! "a" vector for tridiagonal matrix - real(r8) :: b(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! "b" vector for tridiagonal matrix - real(r8) :: c1(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! "c" vector for tridiagonal matrix - real(r8) :: r(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! "r" vector for tridiagonal solution - real(r8) :: rhow(bounds%begc:bounds%endc,nlevlak) ! density of water (kg/m**3) - real(r8) :: phi(bounds%begc:bounds%endc,nlevlak) ! solar radiation absorbed by layer (w/m**2) - real(r8) :: kme(bounds%begc:bounds%endc,nlevlak) ! molecular + eddy diffusion coefficient (m**2/s) - real(r8) :: rsfin ! relative flux of solar radiation into layer - real(r8) :: rsfout ! relative flux of solar radiation out of layer - real(r8) :: phi_soil(bounds%begc:bounds%endc) ! solar radiation into top soil layer (W/m**2) - real(r8) :: ri ! richardson number - real(r8) :: fin(bounds%begc:bounds%endc) ! net heat flux into lake at ground interface (w/m**2) - real(r8) :: ocvts(bounds%begc:bounds%endc) ! (cwat*(t_lake[n ])*dz - real(r8) :: ncvts(bounds%begc:bounds%endc) ! (cwat*(t_lake[n+1])*dz - real(r8) :: ke ! eddy diffusion coefficient (m**2/s) - real(r8) :: zin ! depth at top of layer (m) - real(r8) :: zout ! depth at bottom of layer (m) - real(r8) :: drhodz ! d [rhow] /dz (kg/m**4) - real(r8) :: n2 ! brunt-vaisala frequency (/s**2) - real(r8) :: num ! used in calculating ri - real(r8) :: den ! used in calculating ri - real(r8) :: tav_froz(bounds%begc:bounds%endc) ! used in aver temp for convectively mixed layers (C) - real(r8) :: tav_unfr(bounds%begc:bounds%endc) ! " - real(r8) :: nav(bounds%begc:bounds%endc) ! used in aver temp for convectively mixed layers - real(r8) :: phidum ! temporary value of phi - real(r8) :: iceav(bounds%begc:bounds%endc) ! used in calc aver ice for convectively mixed layers - real(r8) :: qav(bounds%begc:bounds%endc) ! used in calc aver heat content for conv. mixed layers - integer :: jtop(bounds%begc:bounds%endc) ! top level for each column (no longer all 1) - real(r8) :: cv (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! heat capacity of soil/snow [J/(m2 K)] - real(r8) :: tk (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! thermal conductivity of soil/snow [W/(m K)] - ! (at interface below, except for j=0) - real(r8) :: cv_lake (bounds%begc:bounds%endc,1:nlevlak) ! heat capacity [J/(m2 K)] - real(r8) :: tk_lake (bounds%begc:bounds%endc,1:nlevlak) ! thermal conductivity at layer node [W/(m K)] - real(r8) :: cvx (bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! heat capacity for whole column [J/(m2 K)] - real(r8) :: tkix(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! thermal conductivity at layer interfaces - ! for whole column [W/(m K)] - real(r8) :: tx(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! temperature of whole column [K] - real(r8) :: tktopsoillay(bounds%begc:bounds%endc) ! thermal conductivity [W/(m K)] - real(r8) :: fnx(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! heat diffusion through the layer interface below [W/m2] - real(r8) :: phix(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! solar source term for whole column [W/m**2] - real(r8) :: zx(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! interface depth (+ below surface) for whole column [m] - real(r8) :: dzm ! used in computing tridiagonal matrix [m] - real(r8) :: dzp ! used in computing tridiagonal matrix [m] - integer :: jprime ! j - nlevlak - real(r8) :: factx(bounds%begc:bounds%endc,-nlevsno+1:nlevlak+nlevgrnd) ! coefficient used in computing tridiagonal matrix - real(r8) :: t_lake_bef(bounds%begc:bounds%endc,1:nlevlak) ! beginning lake temp for energy conservation check [K] - real(r8) :: t_soisno_bef(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! beginning soil temp for E cons. check [K] - real(r8) :: lhabs(bounds%begc:bounds%endc) ! total per-column latent heat abs. from phase change (J/m^2) - real(r8) :: esum1(bounds%begc:bounds%endc) ! temp for checking energy (J/m^2) - real(r8) :: esum2(bounds%begc:bounds%endc) ! "" - real(r8) :: zsum(bounds%begc:bounds%endc) ! temp for putting ice at the top during convection (m) - real(r8) :: wsum(bounds%begc:bounds%endc) ! temp for checking water (kg/m^2) - real(r8) :: wsum_end(bounds%begc:bounds%endc) ! temp for checking water (kg/m^2) - real(r8) :: sabg_col(bounds%begc:bounds%endc) ! absorbed ground solar for column (W/m^2) - real(r8) :: sabg_lyr_col(bounds%begc:bounds%endc,-nlevsno+1:1) ! absorbed ground solar in layer for column (W/m^2) + real(r8) :: a(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! "a" vector for tridiagonal matrix + real(r8) :: b(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! "b" vector for tridiagonal matrix + real(r8) :: c1(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! "c" vector for tridiagonal matrix + real(r8) :: r(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! "r" vector for tridiagonal solution + real(r8) :: rhow(1:num_lakec,nlevlak) ! density of water (kg/m**3) + real(r8) :: phi(1:num_lakec,nlevlak) ! solar radiation absorbed by layer (w/m**2) + real(r8) :: kme(1:num_lakec,nlevlak) ! molecular + eddy diffusion coefficient (m**2/s) + real(r8) :: rsfin ! relative flux of solar radiation into layer + real(r8) :: rsfout ! relative flux of solar radiation out of layer + real(r8) :: phi_soil(1:num_lakec) ! solar radiation into top soil layer (W/m**2) + real(r8) :: ri ! richardson number + real(r8) :: fin(1:num_lakec) ! net heat flux into lake at ground interface (w/m**2) + real(r8) :: ocvts(1:num_lakec) ! (cwat*(t_lake[n ])*dz + real(r8) :: ncvts(1:num_lakec) ! (cwat*(t_lake[n+1])*dz + real(r8) :: ke ! eddy diffusion coefficient (m**2/s) + real(r8) :: zin ! depth at top of layer (m) + real(r8) :: zout ! depth at bottom of layer (m) + real(r8) :: drhodz ! d [rhow] /dz (kg/m**4) + real(r8) :: n2 ! brunt-vaisala frequency (/s**2) + real(r8) :: num ! used in calculating ri + real(r8) :: den ! used in calculating ri + real(r8) :: tav_froz(1:num_lakec) ! used in aver temp for convectively mixed layers (C) + real(r8) :: tav_unfr(1:num_lakec) ! " + real(r8) :: nav(1:num_lakec) ! used in aver temp for convectively mixed layers + real(r8) :: phidum ! temporary value of phi + real(r8) :: iceav(1:num_lakec) ! used in calc aver ice for convectively mixed layers + real(r8) :: qav(1:num_lakec) ! used in calc aver heat content for conv. mixed layers + integer :: jtop(1:num_lakec) ! top level for each column (no longer all 1) + real(r8) :: cv(1:num_lakec,-nlevsno+1:nlevgrnd) ! heat capacity of soil/snow [J/(m2 K)] + real(r8) :: tk(1:num_lakec,-nlevsno+1:nlevgrnd) ! thermal conductivity of soil/snow [W/(m K)] + ! (at interface below, except for j=0) + real(r8) :: cv_lake(1:num_lakec,1:nlevlak) ! heat capacity [J/(m2 K)] + real(r8) :: tk_lake(1:num_lakec,1:nlevlak) ! thermal conductivity at layer node [W/(m K)] + real(r8) :: cvx (1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! heat capacity for whole column [J/(m2 K)] + real(r8) :: tkix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! thermal conductivity at layer interfaces + ! for whole column [W/(m K)] + real(r8) :: tx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! temperature of whole column [K] + real(r8) :: tktopsoillay(1:num_lakec) ! thermal conductivity [W/(m K)] + real(r8) :: fnx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! heat diffusion through the layer interface below [W/m2] + real(r8) :: phix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! solar source term for whole column [W/m**2] + real(r8) :: zx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! interface depth (+ below surface) for whole column [m] + real(r8) :: dzm ! used in computing tridiagonal matrix [m] + real(r8) :: dzp ! used in computing tridiagonal matrix [m] + integer :: jprime ! j - nlevlak + real(r8) :: factx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ! coefficient used in computing tridiagonal matrix + !NOTE: replace zsum with a scalar ! + real(r8) :: zsum(1:num_lakec) ! temp for putting ice at the top during convection (m) + + !NOTE: sabg_lyr_col seems poorly implemented + real(r8) :: sabg_lyr_col(1:num_lakec,-nlevsno+1:1) ! absorbed ground solar in layer for column (W/m^2) real(r8) :: sabg_nir ! NIR that is absorbed (W/m^2) - integer :: jconvect(bounds%begc:bounds%endc) ! Lowest level where convection occurs - integer :: jconvectbot(bounds%begc:bounds%endc) ! Hightest level where bottom-originating convection occurs - logical :: bottomconvect(bounds%begc:bounds%endc) ! Convection originating in bottom layer of lake triggers special convection loop + integer :: jconvect(1:num_lakec) ! Lowest level where convection occurs + !NOTE: jconvectbot initialization seems unnecessary + integer :: jconvectbot(1:num_lakec) ! Hightest level where bottom-originating convection occurs + logical :: bottomconvect(1:num_lakec) ! Convection originating in bottom layer of lake triggers special convection loop real(r8) :: fangkm ! (m^2/s) extra diffusivity based on Fang & Stefan 1996, citing Ellis, 1991 ! They think that mixing energy will generally get into lake to make ! diffusivity exceed molecular; the energy is damped out according to the Brunt-Vaisala ! frequency, yielding a maximum diffusivity for neutral stability of about 6 times molecular ! For puddling - logical :: puddle(bounds%begc:bounds%endc) - real(r8) :: icesum(bounds%begc:bounds%endc) ! m - logical :: frzn(bounds%begc:bounds%endc) + logical :: puddle(1:num_lakec) + real(r8) :: icesum ! m + logical :: frzn(1:num_lakec) + integer :: lake_col_to_filter(bounds%begc:bounds%endc) + real(r8) :: temp, sum1, sum2,sum3 + real :: startt, stopt, start_all, stop_all + real(r8) :: gam(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) + !----------------------------------------------------------------------- associate( & - dz_lake => col_pp%dz_lake , & ! Input: [real(r8) (:,:) ] layer thickness for lake (m) - z_lake => col_pp%z_lake , & ! Input: [real(r8) (:,:) ] layer depth for lake (m) - dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness for snow & soil (m) - z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer depth for snow & soil (m) - snl => col_pp%snl , & ! Input: [integer (:) ] negative of number of snow layers - lakedepth => col_pp%lakedepth , & ! Input: [real(r8) (:) ] column lake depth (m) + dz_lake => col_pp%dz_lake , & ! Input: [real(r8) (:,:) ] layer thickness for lake (m) + z_lake => col_pp%z_lake , & ! Input: [real(r8) (:,:) ] layer depth for lake (m) + dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer thickness for snow & soil (m) + z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer depth for snow & soil (m) + snl => col_pp%snl , & ! Input: [integer (:) ] negative of number of snow layers + lakedepth => col_pp%lakedepth , & ! Input: [real(r8) (:) ] column lake depth (m) sabg => solarabs_vars%sabg_patch , & ! Input: [real(r8) (:) ] solar radiation absorbed by ground (W/m**2) sabg_lyr => solarabs_vars%sabg_lyr_patch , & ! Input: [real(r8) (:,:) ] absorbed solar radiation (pft,lyr) [W/m2] @@ -231,7 +226,7 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la etal => lakestate_vars%etal_col , & ! Input: [real(r8) (:) ] extinction coefficient from surface data (1/m) ks => lakestate_vars%ks_col , & ! Input: [real(r8) (:) ] coefficient passed to LakeTemperature ws => lakestate_vars%ws_col , & ! Input: [real(r8) (:) ] surface friction velocity (m/s) - lake_raw => lakestate_vars%lake_raw_col , & ! Input: [real(r8) (:) ] aerodynamic resistance for moisture (s/m) + lake_raw => lakestate_vars%lake_raw_col , & ! Input: [real(r8) (:) ] aerodynamic resistance for moisture (s/m) h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) [for snow & soil layers] @@ -258,46 +253,79 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la eflx_sh_grnd => veg_ef%eflx_sh_grnd , & ! Output: [real(r8) (:) ] sensible heat flux from ground (W/m**2) [+ to atm] eflx_sh_tot => veg_ef%eflx_sh_tot , & ! Output: [real(r8) (:) ] total sensible heat flux (W/m**2) [+ to atm] eflx_gnet => veg_ef%eflx_gnet , & ! Output: [real(r8) ( :) ] net heat flux into ground (W/m**2) at the surface interface - errsoi => col_ef%errsoi & ! Output: [real(r8) (:) ] soil/lake energy conservation error (W/m**2) + errsoi => col_ef%errsoi & ! Output: [real(r8) (:) ] soil/lake energy conservation error (W/m**2) ) - + ! 1!) Initialization ! Determine step size - - dtime = dtime_mod !get_step_size() + !$acc enter data create(& + !! ! $acc beta(1:num_lakec), & + !$acc a(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc b(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc c1(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc r(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc rhow(1:num_lakec,1:nlevlak) ,& + !$acc phi(1:num_lakec,1:nlevlak),& + !$acc kme(1:num_lakec,1:nlevlak) ,& + !$acc phi_soil(1:num_lakec) ,& + !$acc fin(1:num_lakec) ,& + !$acc ocvts(1:num_lakec) ,& + !$acc ncvts(1:num_lakec) ,& + !$acc tav_froz(1:num_lakec) ,& + !$acc tav_unfr(1:num_lakec) ,& + !$acc nav(1:num_lakec) ,& + !$acc iceav(1:num_lakec) ,& + !$acc qav(1:num_lakec) ,& + !$acc jtop(1:num_lakec) ,& + !$acc cv(1:num_lakec,-nlevsno+1:nlevgrnd) ,& + !$acc tk(1:num_lakec,-nlevsno+1:nlevgrnd) ,& + !$acc cv_lake(1:num_lakec,1:nlevlak) ,& + !$acc tk_lake(1:num_lakec,1:nlevlak) ,& + !$acc cvx (1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc tkix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc tx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc tktopsoillay(1:num_lakec) ,& + !$acc fnx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc phix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc zx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc factx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd), & + !$acc sabg_lyr_col(1:num_lakec,-nlevsno+1:1), & + !$acc jconvect(1:num_lakec), & + !$acc jconvectbot(1:num_lakec) ,& + !$acc bottomconvect(1:num_lakec) ,& + !$acc puddle(1:num_lakec) , & + !$acc frzn(1:num_lakec) , zsum(1:num_lakec), & + !$acc gam(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd), & + !$acc lake_col_to_filter(bounds%begc:bounds%endc) & + !$acc ) ! Initialize constants cwat = cpliq*denh2o ! water heat capacity per unit volume cice_eff = cpice*denh2o !use water density because layer depth is not adjusted - !for freezing + !for freezing cfus = hfus*denh2o ! latent heat per unit volume tkice_eff = tkice * denice/denh2o !effective conductivity since layer depth is constant km = tkwat/cwat ! a constant (molecular diffusivity) - - ! Needed for Lahey compiler which doesn't seem to allow shortcircuit logic for undefined variables. - puddle(bounds%begc:bounds%endc) = .false. - frzn(bounds%begc:bounds%endc) = .false. - - ! Begin calculations - + !$acc enter data copyin(cwat, cice_eff, cfus, tkice_eff, km) + !$acc enter data create(temp,sum1,sum2,sum3, icesum) + + !Begin Calculations + !$acc parallel loop independent gang vector default(present) private(c) do fc = 1, num_lakec c = filter_lakec(fc) - ! Initialize quantities needed below - - ocvts(c) = 0._r8 - ncvts(c) = 0._r8 - esum1(c) = 0._r8 - esum2(c) = 0._r8 + lake_col_to_filter(c) = fc + ocvts(fc) = 0._r8 + puddle(fc) = .false. + frzn(fc) = .false. + bottomconvect(fc) = .false. hc_soisno(c) = 0._r8 hc_soi(c) = 0._r8 if (use_lch4) then - jconvect(c) = 0 - jconvectbot(c) = nlevlak+1 + jconvect(fc) = 0 + jconvectbot(fc) = nlevlak+1 lakeresist(c) = 0._r8 end if - bottomconvect(bounds%begc:bounds%endc) = .false. - qflx_snofrz_col(c) = 0._r8 end do @@ -306,6 +334,7 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! here because phase change will occur in this routine. ! Ice fraction of snow at previous time step + !$acc parallel loop independent gang vector collapse(2) default(present) !async(1) do j = -nlevsno+1,0 do fc = 1, num_lakec c = filter_lakec(fc) @@ -316,31 +345,29 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la end do ! Prepare for lake layer temperature calculations below - + !$acc parallel loop independent gang vector default(present) private(sabg_nir) do fp = 1, num_lakep p = filter_lakep(fp) c = veg_pp%column(p) - - ! fin(c) = betaprime * sabg(p) + forc_lwrad(c) - (eflx_lwrad_out(p) + & - ! eflx_sh_tot(p) + eflx_lh_tot(p)) - ! fin(c) now passed from LakeFluxes as eflx_gnet - fin(c) = eflx_gnet(p) + fc = lake_col_to_filter(c) + fin(fc) = eflx_gnet(p) ! Calculate the NIR fraction of absorbed solar. This will now be the "beta" parameter. ! Total NIR absorbed: sabg_nir = fsds_nir_d(p) + fsds_nir_i(p) - fsr_nir_d(p) - fsr_nir_i(p) sabg_nir = min(sabg_nir, sabg(p)) - beta(c) = sabg_nir/max(1.e-5_r8,sabg(p)) - beta(c) = beta(c) + (1._r8-beta(c))*betavis - end do + sabg_nir = sabg_nir/max(1.e-5_r8,sabg(p)) + beta(c) = sabg_nir + (1._r8-sabg_nir)*betavis + end do + ! 2!) Lake density - + !$acc parallel loop independent gang vector collapse(2) default(present) private(c) do j = 1, nlevlak do fc = 1, num_lakec c = filter_lakec(fc) - rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * & + rhow(fc,j) = (1._r8 - lake_icefrac(c,j)) * & 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-tdmax))**1.68_r8 ) & + lake_icefrac(c,j)*denice ! Allow for ice fraction; assume constant ice density. @@ -351,13 +378,13 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! convective mixing. end do end do - ! 3!) Diffusivity and implied thermal "conductivity" = diffusivity * cwat + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1, nlevlak-1 do fc = 1, num_lakec c = filter_lakec(fc) - drhodz = (rhow(c,j+1)-rhow(c,j)) / (z_lake(c,j+1)-z_lake(c,j)) - n2 = grav / rhow(c,j) * drhodz + drhodz = (rhow(fc,j+1)-rhow(fc,j)) / (z_lake(c,j+1)-z_lake(c,j)) + n2 = grav / rhow(fc,j) * drhodz ! Fixed sign error here: our z goes up going down into the lake, so no negative ! sign is needed to make this positive unlike in Hostetler. --ZS @@ -365,74 +392,77 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la den = max( (ws(c)**2._r8) * exp(-2._r8*ks(c)*z_lake(c,j)), 1.e-10_r8 ) ri = ( -1._r8 + sqrt( max(1._r8+num/den, 0._r8) ) ) / 20._r8 - if (lakepuddling .and. j == 1) frzn(c) = .false. + if (lakepuddling .and. j == 1) frzn(fc) = .false. if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0 .and. & - (.not. lakepuddling .or. (lake_icefrac(c,j) == 0._r8 .and. .not. frzn(c))) ) then + (.not. lakepuddling .or. (lake_icefrac(c,j) == 0._r8 .and. .not. frzn(fc))) ) then ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri) - kme(c,j) = km + ke + kme(fc,j) = km + ke if (.not. lake_no_ed) then - fangkm = 1.039e-8_r8 * max(n2,n2min)**(-0.43_r8) ! Fang & Stefan 1996, citing Ellis et al 1991 - kme(c,j) = kme(c,j) + fangkm + ! Fang & Stefan 1996, citing Ellis et al 1991 + fangkm = 1.039e-8_r8 * max(n2,n2min)**(-0.43_r8) + kme(fc,j) = kme(fc,j) + fangkm end if if (lakedepth(c) >= depthcrit) then - kme(c,j) = kme(c,j) * mixfact + kme(fc,j) = kme(fc,j) * mixfact end if - tk_lake(c,j) = kme(c,j)*cwat + tk_lake(fc,j) = kme(fc,j)*cwat else - kme(c,j) = km + kme(fc,j) = km if (.not. lake_no_ed) then fangkm = 1.039e-8_r8 * max(n2,n2min)**(-0.43_r8) - kme(c,j) = kme(c,j) + fangkm + kme(fc,j) = kme(fc,j) + fangkm if (lakedepth(c) >= depthcrit) then - kme(c,j) = kme(c,j) * mixfact + kme(fc,j) = kme(fc,j) * mixfact end if - tk_lake(c,j) = kme(c,j)*cwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & - + kme(c,j)*cwat*lake_icefrac(c,j) ) + tk_lake(fc,j) = kme(fc,j)*cwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + + kme(fc,j)*cwat*lake_icefrac(c,j) ) else - tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + tk_lake(fc,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + tkwat*lake_icefrac(c,j) ) ! Assume the resistances add as for the calculation of conductivities at layer interfaces. end if - if (lakepuddling) frzn(c) = .true. + if (lakepuddling) frzn(fc) = .true. ! Prevent eddy mixing beneath frozen layers even when surface is unfrozen. end if end do end do + !$acc parallel loop independent gang vector default(present) private(c,j) do fc = 1, num_lakec c = filter_lakec(fc) j = nlevlak - kme(c,nlevlak) = kme(c,nlevlak-1) + kme(fc,nlevlak) = kme(fc,nlevlak-1) if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0 .and. & - (.not. lakepuddling .or. (lake_icefrac(c,j) == 0._r8 .and. .not. frzn(c)) ) ) then - tk_lake(c,j) = tk_lake(c,j-1) + (.not. lakepuddling .or. (lake_icefrac(c,j) == 0._r8 .and. .not. frzn(fc)) ) ) then + tk_lake(fc,j) = tk_lake(fc,j-1) else if (.not. lake_no_ed) then - tk_lake(c,j) = kme(c,j)*cwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & - + kme(c,j)*cwat*lake_icefrac(c,j) ) + tk_lake(fc,j) = kme(fc,j)*cwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + + kme(fc,j)*cwat*lake_icefrac(c,j) ) else - tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + tk_lake(fc,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff & + tkwat*lake_icefrac(c,j) ) end if end if ! Use in surface flux calculation for next timestep. - savedtke1(c) = kme(c,1)*cwat ! Will only be used if unfrozen + savedtke1(c) = kme(fc,1)*cwat ! Will only be used if unfrozen ! set number of column levels for use by Tridiagonal below - jtop(c) = snl(c) + 1 + jtop(fc) = snl(c) + 1 end do ! 4!) Heat source term + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1, nlevlak do fp = 1, num_lakep p = filter_lakep(fp) c = veg_pp%column(p) - + fc = lake_col_to_filter(c) ! If no eta from surface data, ! Set eta, the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995 ! (regression of Secchi Depth with lake depth for small glacial basin lakes), and the @@ -455,7 +485,7 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then phidum = (rsfin-rsfout) * sabg(p) * (1._r8-beta(c)) if (j == nlevlak) then - phi_soil(c) = rsfout * sabg(p) * (1._r8-beta(c)) + phi_soil(fc) = rsfout * sabg(p) * (1._r8-beta(c)) end if else if (j == 1 .and. snl(c) == 0) then !if frozen but no snow layers phidum = sabg(p) * (1._r8-beta(c)) @@ -467,29 +497,27 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la !radiation absorbed in snow layers will be applied below else phidum = 0._r8 - if (j == nlevlak) phi_soil(c) = 0._r8 + if (j == nlevlak) phi_soil(fc) = 0._r8 end if - phi(c,j) = phidum + phi(fc,j) = phidum end do end do ! 5!) Set thermal properties and check initial energy content. - ! For lake + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1, nlevlak do fc = 1, num_lakec c = filter_lakec(fc) - - cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + cv_lake(fc,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) end do end do - ! For snow / soil call SoilThermProp_Lake(bounds, num_lakec, filter_lakec, & - tk(bounds%begc:bounds%endc, :), & - cv(bounds%begc:bounds%endc, :), & - tktopsoillay(bounds%begc:bounds%endc), & + tk(1:num_lakec, :), & + cv(1:num_lakec, :), & + tktopsoillay(1:num_lakec), & soilstate_vars) ! Sum cv*t_lake for energy check @@ -497,30 +525,37 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! to prevent abrupt change in heat content due to changing heat capacity with phase change. ! This will need to be over all soil / lake / snow layers. Lake is below. - do j = 1, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - ocvts(c) = ocvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & - + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) - t_lake_bef(c,j) = t_lake(c,j) - end do + !$acc parallel loop independent gang worker default(present) private(c,temp) + do fc = 1, num_lakec + c = filter_lakec(fc) + temp = 0._r8 + !$acc loop vector reduction(+:temp) + do j = 1, nlevlak + temp = temp + cv_lake(fc,j)*(t_lake(c,j)-tfrz) + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) + !t_lake_bef(c,j) = t_lake(c,j) + end do + ocvts(fc) = ocvts(fc) + temp end do - + + ! Now do for soil / snow layers - do j = -nlevsno + 1, nlevgrnd - do fc = 1, num_lakec - c = filter_lakec(fc) - - if (j >= jtop(c)) then - ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & - + hfus*h2osoi_liq(c,j) - if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then - ocvts(c) = ocvts(c) - h2osno(c)*hfus + !$acc parallel loop independent gang worker default(present) private(temp,c) + do fc = 1, num_lakec + c = filter_lakec(fc) + temp = 0._r8 + !$acc loop vector reduction(+:temp) + do j = -nlevsno + 1, nlevgrnd + if (j >= jtop(fc)) then + temp = temp + cv(fc,j)*(t_soisno(c,j)-tfrz) + hfus*h2osoi_liq(c,j) + if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(fc)) then + temp = temp-h2osno(c)*hfus end if - t_soisno_bef(c,j) = t_soisno(c,j) + !t_soisno_bef(c,j) = t_soisno(c,j) end if + end do + ocvts(fc) = ocvts(fc) + temp end do !!!!!!!!!!!!!!!!!!! @@ -530,50 +565,53 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! but its capacity to absorb latent heat may be used during phase change. ! Transfer sabg and sabg_lyr to column level + !$acc parallel loop independent gang vector collapse(2) default(present) private(p,c,fc) do j = -nlevsno+1,1 do fp = 1, num_lakep p = filter_lakep(fp) c = veg_pp%column(p) + fc = lake_col_to_filter(c) - if (j >= jtop(c)) then - if (j == jtop(c)) sabg_col(c) = sabg(p) - sabg_lyr_col(c,j) = sabg_lyr(p,j) + if (j >= jtop(fc)) then + ! if (j == jtop(c)) sabg_col(c) = sabg(p) + sabg_lyr_col(fc,j) = sabg_lyr(p,j) end if end do end do - - ! Set up interface depths, zx, heat capacities, cvx, solar source terms, phix, and temperatures, tx. + + ! Set up interface depths, zx, heat capacities, cvx, solar source terms, phix, and temperatures, tx. + !$acc parallel loop independent gang vector collapse(2) default(present) private(c, jprime) do j = -nlevsno+1, nlevlak+nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) jprime = j - nlevlak - if (j >= jtop(c)) then + if (j >= jtop(fc)) then if (j < 1) then !snow layer - zx(c,j) = z(c,j) - cvx(c,j) = cv(c,j) - if (j == jtop(c)) then ! no absorption because it has already been assigned to the surface + zx(fc,j) = z(c,j) + cvx(fc,j) = cv(fc,j) + if (j == jtop(fc)) then ! no absorption because it has already been assigned to the surface ! interface - phix(c,j) = 0._r8 + phix(fc,j) = 0._r8 else - phix(c,j) = sabg_lyr_col(c,j) !New for SNICAR + phix(fc,j) = sabg_lyr_col(fc,j) !New for SNICAR end if - tx(c,j) = t_soisno(c,j) + tx(fc,j) = t_soisno(c,j) else if (j <= nlevlak) then !lake layer - zx(c,j) = z_lake(c,j) - cvx(c,j) = cv_lake(c,j) - phix(c,j) = phi(c,j) - tx(c,j) = t_lake(c,j) + zx(fc,j) = z_lake(c,j) + cvx(fc,j) = cv_lake(fc,j) + phix(fc,j) = phi(fc,j) + tx(fc,j) = t_lake(c,j) else !soil layer - zx(c,j) = zx(c,nlevlak) + dz_lake(c,nlevlak)/2._r8 + z(c,jprime) - cvx(c,j) = cv(c,jprime) + zx(fc,j) = zx(fc,nlevlak) + dz_lake(c,nlevlak)/2._r8 + z(c,jprime) + cvx(fc,j) = cv(fc,jprime) if (j == nlevlak + 1) then !top soil layer - phix(c,j) = phi_soil(c) + phix(fc,j) = phi_soil(fc) else !middle or bottom soil layer - phix(c,j) = 0._r8 + phix(fc,j) = 0._r8 end if - tx(c,j) = t_soisno(c,jprime) + tx(fc,j) = t_soisno(c,jprime) end if end if @@ -581,98 +619,115 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la end do ! Determine interface thermal conductivities, tkix - + !$acc parallel loop independent gang vector collapse(2) default(present) private(c) do j = -nlevsno+1, nlevlak+nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) jprime = j - nlevlak - if (j >= jtop(c)) then + if (j >= jtop(fc)) then if (j < 0) then !non-bottom snow layer - tkix(c,j) = tk(c,j) + tkix(fc,j) = tk(fc,j) else if (j == 0) then !bottom snow layer - dzp = zx(c,j+1) - zx(c,j) - tkix(c,j) = tk_lake(c,1)*tk(c,j)*dzp / & - (tk(c,j)*z_lake(c,1) + tk_lake(c,1)*(-z(c,j)) ) - ! tk(c,0) is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake + dzp = zx(fc,j+1) - zx(fc,j) + tkix(fc,j) = tk_lake(fc,1)*tk(fc,j)*dzp / & + (tk(fc,j)*z_lake(c,1) + tk_lake(fc,1)*(-z(c,j)) ) + ! tk(fc,0) is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake else if (j < nlevlak) then !non-bottom lake layer - tkix(c,j) = ( tk_lake(c,j)*tk_lake(c,j+1) * (dz_lake(c,j+1)+dz_lake(c,j)) ) & - / ( tk_lake(c,j)*dz_lake(c,j+1) + tk_lake(c,j+1)*dz_lake(c,j) ) + tkix(fc,j) = ( tk_lake(fc,j)*tk_lake(fc,j+1) * (dz_lake(c,j+1)+dz_lake(c,j)) ) & + / ( tk_lake(fc,j)*dz_lake(c,j+1) + tk_lake(fc,j+1)*dz_lake(c,j) ) else if (j == nlevlak) then !bottom lake layer - dzp = zx(c,j+1) - zx(c,j) - tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / & - (tktopsoillay(c)*dz_lake(c,j)/2._r8 + tk_lake(c,j)*z(c,1) ) ) + dzp = zx(fc,j+1) - zx(fc,j) + tkix(fc,j) = (tktopsoillay(fc)*tk_lake(fc,j)*dzp / & + (tktopsoillay(fc)*dz_lake(c,j)/2._r8 + tk_lake(fc,j)*z(c,1) ) ) ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake else !soil layer - tkix(c,j) = tk(c,jprime) + tkix(fc,j) = tk(fc,jprime) end if end if end do end do - ! Determine heat diffusion through the layer interface and factor used in computing ! tridiagonal matrix and set up vector r and vectors a, b, c1 that define tridiagonal ! matrix and solve system - + + !$acc parallel loop independent gang vector collapse(2) default(present) private(c) do j = -nlevsno+1, nlevlak+nlevgrnd do fc = 1,num_lakec - c = filter_lakec(fc) - if (j >= jtop(c)) then + if (j >= jtop(fc)) then if (j < nlevlak+nlevgrnd) then !top or interior layer - factx(c,j) = dtime/cvx(c,j) - fnx(c,j) = tkix(c,j)*(tx(c,j+1)-tx(c,j))/(zx(c,j+1)-zx(c,j)) + factx(fc,j) = dtime_mod/cvx(fc,j) + fnx(fc,j) = tkix(fc,j)*(tx(fc,j+1)-tx(fc,j))/(zx(fc,j+1)-zx(fc,j)) else !bottom soil layer - factx(c,j) = dtime/cvx(c,j) - fnx(c,j) = 0._r8 !not used + factx(fc,j) = dtime_mod/cvx(fc,j) + fnx(fc,j) = 0._r8 !not used end if end if enddo end do + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1,nlevlak+nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) - if (j >= jtop(c)) then - if (j == jtop(c)) then !top layer - dzp = zx(c,j+1)-zx(c,j) - a(c,j) = 0._r8 - b(c,j) = 1+(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp - c1(c,j) = -(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp - r(c,j) = tx(c,j) + factx(c,j)*( fin(c) + phix(c,j) + cnfac*fnx(c,j) ) + if (j >= jtop(fc)) then + if (j == jtop(fc)) then !top layer + dzp = zx(fc,j+1)-zx(fc,j) + a(fc,j) = 0._r8 + b(fc,j) = 1+(1._r8-cnfac)*factx(fc,j)*tkix(fc,j)/dzp + c1(fc,j) = -(1._r8-cnfac)*factx(fc,j)*tkix(fc,j)/dzp + r(fc,j) = tx(fc,j) + factx(fc,j)*( fin(fc) + phix(fc,j) + cnfac*fnx(fc,j) ) else if (j < nlevlak+nlevgrnd) then !middle layer - dzm = (zx(c,j)-zx(c,j-1)) - dzp = (zx(c,j+1)-zx(c,j)) - a(c,j) = - (1._r8-cnfac)*factx(c,j)* tkix(c,j-1)/dzm - b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm) - c1(c,j) = - (1._r8-cnfac)*factx(c,j)* tkix(c,j)/dzp - r(c,j) = tx(c,j) + cnfac*factx(c,j)*( fnx(c,j) - fnx(c,j-1) ) + factx(c,j)*phix(c,j) + dzm = (zx(fc,j)-zx(fc,j-1)) + dzp = (zx(fc,j+1)-zx(fc,j)) + a(fc,j) = - (1._r8-cnfac)*factx(fc,j)* tkix(fc,j-1)/dzm + b(fc,j) = 1._r8+ (1._r8-cnfac)*factx(fc,j)*(tkix(fc,j)/dzp + tkix(fc,j-1)/dzm) + c1(fc,j) = - (1._r8-cnfac)*factx(fc,j)* tkix(fc,j)/dzp + r(fc,j) = tx(fc,j) + cnfac*factx(fc,j)*( fnx(fc,j) - fnx(fc,j-1) ) + factx(fc,j)*phix(fc,j) else !bottom soil layer - dzm = (zx(c,j)-zx(c,j-1)) - a(c,j) = - (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm - b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm - c1(c,j) = 0._r8 - r(c,j) = tx(c,j) - cnfac*factx(c,j)*fnx(c,j-1) + dzm = (zx(fc,j)-zx(fc,j-1)) + a(fc,j) = - (1._r8-cnfac)*factx(fc,j)*tkix(fc,j-1)/dzm + b(fc,j) = 1._r8+ (1._r8-cnfac)*factx(fc,j)*tkix(fc,j-1)/dzm + c1(fc,j) = 0._r8 + r(fc,j) = tx(fc,j) - cnfac*factx(fc,j)*fnx(fc,j-1) end if end if enddo end do - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !$acc parallel loop independent gang vector default(present) private(c) + do fc = 1,num_lakec + c = filter_lakec(fc) + + !$acc loop seq + do j = -nlevsno + 1, nlevlak + nlevgrnd + !if(l_is_col_active(ci))then + if (j >= jtop(fc)) then + if (j == jtop(fc)) then + tx(fc,j) = r(fc,j) / b(fc,jtop(fc)) + else + gam(fc,j) = c1(fc,j-1) / b(fc,jtop(fc)) + b(fc,jtop(fc)) = b(fc,j) - a(fc,j) * gam(fc,j) + tx(fc,j) = (r(fc,j) - a(fc,j)*tx(fc,j-1)) / b(fc,jtop(fc)) + end if + end if + !endif + end do - ! 7!) Solve for tdsolution - call Tridiagonal(bounds, -nlevsno + 1, nlevlak + nlevgrnd, & - jtop(bounds%begc:bounds%endc), & - num_lakec, filter_lakec, & - a(bounds%begc:bounds%endc, :), & - b(bounds%begc:bounds%endc, :), & - c1(bounds%begc:bounds%endc, :), & - r(bounds%begc:bounds%endc, :), & - tx(bounds%begc:bounds%endc, :)) + !$acc loop seq + do j = nlevlak + nlevgrnd-1,-nlevsno + 1,-1 + if (j >= jtop(fc)) then + tx(fc,j) = tx(fc,j) - gam(fc,j+1) * tx(fc,j+1) + end if + end do + end do + ! Set t_soisno and t_lake + !$acc parallel loop independent gang vector default(present) collapse(2) private(jprime) do j = -nlevsno+1, nlevlak + nlevgrnd do fc = 1, num_lakec c = filter_lakec(fc) @@ -680,13 +735,13 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la jprime = j - nlevlak ! Don't do anything with invalid snow layers. - if (j >= jtop(c)) then + if (j >= jtop(fc)) then if (j < 1) then !snow layer - t_soisno(c,j) = tx(c,j) + t_soisno(c,j) = tx(fc,j) else if (j <= nlevlak) then !lake layer - t_lake(c,j) = tx(c,j) + t_lake(c,j) = tx(fc,j) else !soil layer - t_soisno(c,jprime) = tx(c,j) + t_soisno(c,jprime) = tx(fc,j) end if end if end do @@ -701,13 +756,10 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! 9!) Phase change call PhaseChange_Lake(bounds, num_lakec, filter_lakec, & - cv(bounds%begc:bounds%endc, :), & - cv_lake(bounds%begc:bounds%endc, :), & - lhabs(bounds%begc:bounds%endc), & - energyflux_vars, lakestate_vars, dtime) - + cv(1:num_lakec, :), & + cv_lake(1:num_lakec, :), & + lakestate_vars, dtime_mod) !!!!!!!!!!!!!!!!!!!!!!! - ! 9.5!) Second energy check and water check. Now check energy balance before and after phase ! change, considering the possibility of changed heat capacity during phase change, by ! using initial heat capacity in the first step, final heat capacity in the second step, @@ -721,30 +773,34 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger. !Recalculate density + + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevlak do fc = 1, num_lakec c = filter_lakec(fc) - rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * & + rhow(fc,j) = (1._r8 - lake_icefrac(c,j)) * & 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-tdmax))**1.68_r8 ) & + lake_icefrac(c,j)*denice end do end do + if (lakepuddling) then ! For sensitivity tests - do j = 1, nlevlak - do fc = 1, num_lakec + !$acc parallel loop independent gang vector default(present) collapse(2) + do j = 1, nlevlak + do fc = 1, num_lakec c = filter_lakec(fc) if (j == 1) then - icesum(c) = 0._r8 - puddle(c) = .false. + icesum = 0._r8 + puddle(fc) = .false. end if - icesum(c) = icesum(c) + lake_icefrac(c,j)*dz(c,j) + icesum = icesum + lake_icefrac(c,j)*dz(c,j) if (j == nlevlak) then - if (icesum(c) >= pudz) puddle(c) = .true. + if (icesum >= pudz) puddle(fc) = .true. end if end do end do @@ -759,154 +815,168 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la ! First examine top nlevlak-1 layers. do j = 1, nlevlak-2 - do fc = 1, num_lakec - c = filter_lakec(fc) - qav(c) = 0._r8 - nav(c) = 0._r8 - iceav(c) = 0._r8 - end do - - do i = 1, j+1 - do fc = 1, num_lakec - c = filter_lakec(fc) - if ( (.not. lakepuddling .or. .not. puddle(c) ) .and. (rhow(c,j) > rhow(c,j+1) .or. & - (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then - qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fc = 1, num_lakec + c = filter_lakec(fc) + if (use_lch4) then + jconvect(fc) = j+1 + end if + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8 + if ( (.not. lakepuddling .or. .not. puddle(fc) )) then + !$acc loop vector reduction(+:sum1,sum2,sum3) + do i = 1, j+1 + if ( (rhow(fc,j) > rhow(fc,j+1) .or. & + (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then + + sum1 = sum1 + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & ((1._r8 - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) - !tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) - iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i) - nav(c) = nav(c) + dz_lake(c,i) - if (use_lch4) then - jconvect(c) = j+1 - end if - end if - end do - end do + !tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) + sum2 = sum2 + lake_icefrac(c,i)*dz_lake(c,i) + sum3 = sum3 + dz_lake(c,i) + end if + end do + end if + qav(fc) = sum1 + iceav(fc) = sum2 + nav(fc) = sum3 + end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) - - if ( (.not. lakepuddling .or. .not. puddle(c) ) .and. (rhow(c,j) > rhow(c,j+1) .or. & + if ( (.not. lakepuddling .or. .not. puddle(fc) ) .and. (rhow(fc,j) > rhow(fc,j+1) .or. & (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then - qav(c) = qav(c)/nav(c) - iceav(c) = iceav(c)/nav(c) + qav(fc) = qav(fc)/nav(fc) + iceav(fc) = iceav(fc)/nav(fc) !If the average temperature is above freezing, put the extra energy into the water. !If it is below freezing, take it away from the ice. - if (qav(c) > 0._r8) then - tav_froz(c) = 0._r8 !Celsius - tav_unfr(c) = qav(c) / ((1._r8 - iceav(c))*cwat) - else if (qav(c) < 0._r8) then - tav_froz(c) = qav(c) / (iceav(c)*cice_eff) - tav_unfr(c) = 0._r8 !Celsius + if (qav(fc) > 0._r8) then + tav_froz(fc) = 0._r8 !Celsius + tav_unfr(fc) = qav(fc) / ((1._r8 - iceav(fc))*cwat) + else if (qav(fc) < 0._r8) then + tav_froz(fc) = qav(fc) / (iceav(fc)*cice_eff) + tav_unfr(fc) = 0._r8 !Celsius else - tav_froz(c) = 0._r8 - tav_unfr(c) = 0._r8 + tav_froz(fc) = 0._r8 + tav_unfr(fc) = 0._r8 end if end if - end do + end do - do i = 1, j+1 - do fc = 1, num_lakec - c = filter_lakec(fc) - if (nav(c) > 0._r8) then + !$acc parallel loop independent gang vector default(present) copyin(j) + do fc = 1, num_lakec + c = filter_lakec(fc) + if (nav(fc) > 0._r8) then + !$acc loop seq + do i = 1, j+1 !Put all the ice at the top.! !If the average temperature is above freezing, put the extra energy into the water. !If it is below freezing, take it away from the ice. !For the layer with both ice & water, be careful to use the average temperature !that preserves the correct total heat content given what the heat capacity of that !layer will actually be. - if (i == 1) zsum(c) = 0._r8 - if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then + if (i == 1) zsum(fc) = 0._r8 + if ((zsum(fc)+dz_lake(c,i))/nav(fc) <= iceav(fc)) then lake_icefrac(c,i) = 1._r8 - t_lake(c,i) = tav_froz(c) + tfrz - else if (zsum(c)/nav(c) < iceav(c)) then - lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) + t_lake(c,i) = tav_froz(fc) + tfrz + else if (zsum(fc)/nav(fc) < iceav(fc)) then + lake_icefrac(c,i) = (iceav(fc)*nav(fc) - zsum(fc)) / dz_lake(c,i) ! Find average value that preserves correct heat content. - t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & - + (1._r8 - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & + t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(fc)*cice_eff & + + (1._r8 - lake_icefrac(c,i))*tav_unfr(fc)*cwat ) & / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz else lake_icefrac(c,i) = 0._r8 - t_lake(c,i) = tav_unfr(c) + tfrz + t_lake(c,i) = tav_unfr(fc) + tfrz end if - zsum(c) = zsum(c) + dz_lake(c,i) + zsum(fc) = zsum(fc) + dz_lake(c,i) - rhow(c,i) = (1._r8 - lake_icefrac(c,i)) * & + rhow(fc,i) = (1._r8 - lake_icefrac(c,i)) * & 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,i)-tdmax))**1.68_r8 ) & + lake_icefrac(c,i)*denice - end if - end do + end do + end if + end do - end do + + end do !j loop ! Now check bottom layer j = nlevlak-1 + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec - c = filter_lakec(fc) + c = filter_lakec(fc) - if ( (.not. lakepuddling .or. .not. puddle(c) ) .and. (rhow(c,j) > rhow(c,j+1) .or. & + if ( (.not. lakepuddling .or. .not. puddle(fc) ) .and. (rhow(fc,j) > rhow(fc,j+1) .or. & (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then ! convection originating in bottom layer. Could be coming from sediments-- be careful not to ! unnecessarily mix all the way to the top of the lake - bottomconvect(c) = .true. + bottomconvect(fc) = .true. end if end do ! Start mixing from bottom up. Only mix as high as the unstable density profile persists. do j = nlevlak-1, 1, -1 - do fc = 1, num_lakec - c = filter_lakec(fc) - qav(c) = 0._r8 - nav(c) = 0._r8 - iceav(c) = 0._r8 - end do - - do i = j, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - if ( bottomconvect(c) .and. & - (.not. lakepuddling .or. .not. puddle(c) ) .and. (rhow(c,j) > rhow(c,j+1) .or. & + + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8 + if (use_lch4) then + jconvectbot(fc) = j + end if + if(bottomconvect(fc)) then + !$acc loop vector reduction(+:sum1,sum2,sum3) + do i = j, nlevlak + if ((.not. lakepuddling .or. .not. puddle(fc) ) .and. (rhow(fc,j) > rhow(fc,j+1) .or. & (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then - qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & + + sum1 = sum1 + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & ((1._r8 - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff) - !tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) - iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i) - nav(c) = nav(c) + dz_lake(c,i) - if (use_lch4) then - jconvectbot(c) = j - end if - end if - end do - end do + !tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i) + sum2 = sum2 + lake_icefrac(c,i)*dz_lake(c,i) + sum3 = sum3 + dz_lake(c,i) + end if + end do + end if + qav(fc) = sum1 + iceav(fc) = sum2 + nav(fc) = sum3 + end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) - if ( bottomconvect(c) .and. & - (.not. lakepuddling .or. .not. puddle(c) ) .and. (rhow(c,j) > rhow(c,j+1) .or. & + if ( bottomconvect(fc) .and. & + (.not. lakepuddling .or. .not. puddle(fc) ) .and. (rhow(fc,j) > rhow(fc,j+1) .or. & (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) ) then - qav(c) = qav(c)/nav(c) - iceav(c) = iceav(c)/nav(c) + qav(fc) = qav(fc)/nav(fc) + iceav(fc) = iceav(fc)/nav(fc) !If the average temperature is above freezing, put the extra energy into the water. !If it is below freezing, take it away from the ice. - if (qav(c) > 0._r8) then - tav_froz(c) = 0._r8 !Celsius - tav_unfr(c) = qav(c) / ((1._r8 - iceav(c))*cwat) - else if (qav(c) < 0._r8) then - tav_froz(c) = qav(c) / (iceav(c)*cice_eff) - tav_unfr(c) = 0._r8 !Celsius + if (qav(fc) > 0._r8) then + tav_froz(fc) = 0._r8 !Celsius + tav_unfr(fc) = qav(fc) / ((1._r8 - iceav(fc))*cwat) + else if (qav(fc) < 0._r8) then + tav_froz(fc) = qav(fc) / (iceav(fc)*cice_eff) + tav_unfr(fc) = 0._r8 !Celsius else - tav_froz(c) = 0._r8 - tav_unfr(c) = 0._r8 + tav_froz(fc) = 0._r8 + tav_unfr(fc) = 0._r8 end if end if end do - do i = j, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - if (bottomconvect(c) .and. nav(c) > 0._r8) then + !$acc parallel loop independent gang vector default(present) copyin(j) + do fc = 1, num_lakec + + c = filter_lakec(fc) + if (bottomconvect(fc) .and. nav(fc) > 0._r8) then + + !$acc loop seq + do i = j, nlevlak !Put all the ice at the top.! !If the average temperature is above freezing, put the extra energy into the water. @@ -915,138 +985,216 @@ subroutine LakeTemperature(bounds, num_lakec, filter_lakec, num_lakep, filter_la !that preserves the correct total heat content given what the heat capacity of that !layer will actually be. - if (i == j) zsum(c) = 0._r8 - if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then + if (i == j) zsum(fc) = 0._r8 + if ((zsum(fc)+dz_lake(c,i))/nav(fc) <= iceav(fc)) then lake_icefrac(c,i) = 1._r8 - t_lake(c,i) = tav_froz(c) + tfrz - else if (zsum(c)/nav(c) < iceav(c)) then - lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i) + t_lake(c,i) = tav_froz(fc) + tfrz + else if (zsum(fc)/nav(fc) < iceav(fc)) then + lake_icefrac(c,i) = (iceav(fc)*nav(fc) - zsum(fc)) / dz_lake(c,i) ! Find average value that preserves correct heat content. - t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff & - + (1._r8 - lake_icefrac(c,i))*tav_unfr(c)*cwat ) & + t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(fc)*cice_eff & + + (1._r8 - lake_icefrac(c,i))*tav_unfr(fc)*cwat ) & / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz else lake_icefrac(c,i) = 0._r8 - t_lake(c,i) = tav_unfr(c) + tfrz + t_lake(c,i) = tav_unfr(fc) + tfrz end if - zsum(c) = zsum(c) + dz_lake(c,i) + zsum(fc) = zsum(fc) + dz_lake(c,i) - rhow(c,i) = (1._r8 - lake_icefrac(c,i)) * & + rhow(fc,i) = (1._r8 - lake_icefrac(c,i)) * & 1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,i)-tdmax))**1.68_r8 ) & + lake_icefrac(c,i)*denice - end if - end do - end do - end do + end do + end if + end do + end do ! j loop ! Calculate lakeresist and grnd_ch4_cond for CH4 Module ! The CH4 will diffuse directly from the top soil layer to the atmosphere, so ! the whole lake resistance is included. if (use_lch4) then - do j = 1, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - - if (j > jconvect(c) .and. j < jconvectbot(c)) then ! Assume resistance is zero for levels that convect - lakeresist(c) = lakeresist(c) + dz(c,j)/kme(c,j) ! dz/eddy or molecular diffusivity - end if - - if (j == nlevlak) then ! Calculate grnd_ch4_cond - grnd_ch4_cond(c) = 1._r8 / (lakeresist(c) + lake_raw(c)) - - ! Lake water R + aerodynamic R - ! Snow will be considered in methane routine - ! No methane conduction through frozen lake - if (lake_icefrac(c,1) > 0.1_r8) grnd_ch4_cond(c) = 0._r8 - end if - - end do + !$acc parallel loop independent gang worker default(present) private(temp) + do fc = 1, num_lakec + c = filter_lakec(fc) + temp = 0._r8 + !$acc loop vector reduction(+:temp) + do j = 1, nlevlak + if (j > jconvect(fc) .and. j < jconvectbot(fc)) then ! Assume resistance is zero for levels that convect + temp = temp + dz(c,j)/kme(fc,j) ! dz/eddy or molecular diffusivity + end if + ! if (j == nlevlak) then ! Calculate grnd_ch4_cond + ! grnd_ch4_cond(c) = 1._r8 / (lakeresist(c) + lake_raw(c)) + + ! ! Lake water R + aerodynamic R + ! ! Snow will be considered in methane routine + ! ! No methane conduction through frozen lake + ! if (lake_icefrac(c,1) > 0.1_r8) grnd_ch4_cond(c) = 0._r8 + ! end if + end do + !NOTE: lakeresist is initialized to zero. can be removed + lakeresist(c) = lakeresist(c) + temp + grnd_ch4_cond(c) = 1._r8 / (lakeresist(c) + lake_raw(c)) + + ! Lake water R + aerodynamic R + ! Snow will be considered in methane routine + ! No methane conduction through frozen lake + if (lake_icefrac(c,1) > 0.1_r8) grnd_ch4_cond(c) = 0._r8 end do end if !!!!!!!!!!!!!!!!!!!!!!! ! 11!) Re-evaluate thermal properties and sum energy content. ! For lake + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1, nlevlak do fc = 1, num_lakec c = filter_lakec(fc) - - cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) + cv_lake(fc,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j)) end do end do ! For snow / soil call SoilThermProp_Lake(bounds, num_lakec, filter_lakec, & - tk(bounds%begc:bounds%endc, :), & - cv(bounds%begc:bounds%endc, :), & - tktopsoillay(bounds%begc:bounds%endc), & + tk(1:num_lakec, :), & + cv(1:num_lakec, :), & + tktopsoillay(1:num_lakec), & soilstate_vars) - - + ! Do as above to sum energy content - do j = 1, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - - ncvts(c) = ncvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) & + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = 1, nlevlak + sum1 = sum1 + cv_lake(fc,j)*(t_lake(c,j)-tfrz) & + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) - fin(c) = fin(c) + phi(c,j) + sum2 = sum2 + phi(fc,j) ! New for CLM 4 - hc_soisno(c) = hc_soisno(c) + cv_lake(c,j)*t_lake(c,j)/1.e6 + sum3 = sum3 + cv_lake(fc,j)*t_lake(c,j)/1.e6 end do + ncvts(fc) = sum1 + fin(fc) = fin(fc) + sum2 + hc_soisno(c) = sum3 end do - do j = -nlevsno + 1, nlevgrnd - do fc = 1, num_lakec - c = filter_lakec(fc) - - if (j >= jtop(c)) then - ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) & + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3,temp) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + temp = 0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = -nlevsno + 1, nlevgrnd + if (j >= jtop(fc)) then + sum1 = sum1 + cv(fc,j)*(t_soisno(c,j)-tfrz) & + hfus*h2osoi_liq(c,j) - if (j < 1) fin(c) = fin(c) + phix(c,j) !For SNICAR - if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then - ncvts(c) = ncvts(c) - h2osno(c)*hfus + + if (j < 1) then + sum2 = sum2 + phix(fc,j) !For SNICAR + end if + if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(fc)) then + sum1 = sum1 - h2osno(c)*hfus end if - hc_soisno(c) = hc_soisno(c) + cv(c,j)*t_soisno(c,j)/1.e6 - if (j >= 1) hc_soi(c) = hc_soi(c) + cv(c,j)*t_soisno(c,j)/1.e6 + sum3 = sum3 + cv(fc,j)*t_soisno(c,j)/1.e6 + if (j >= 1) then + temp = temp + cv(fc,j)*t_soisno(c,j)/1.e6 + end if + end if - if (j == 1) fin(c) = fin(c) + phi_soil(c) + + if (j == 1) sum2 = sum2 + phi_soil(fc) end do + ncvts(fc) = ncvts(fc) + sum1 + fin(fc) = fin(fc) + sum2 + hc_soisno(c) = hc_soisno(c) + sum3 + hc_soi(c) = hc_soi(c) + temp + end do + + !$acc parallel loop independent gang vector default(present) private(c) + do fc = 1, num_lakec + c = filter_lakec(fc) + errsoi(c) = (ncvts(fc)-ocvts(fc)) / dtime_mod - fin(fc) end do - ! Check energy conservation. + ! NOTE: separate this into two loops to avoid a filter to column index? + !$acc parallel loop independent gang vector default(present) private(p,c,fc) do fp = 1, num_lakep p = filter_lakep(fp) c = veg_pp%column(p) - errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c) + if (abs(errsoi(c)) < 0.10_r8) then ! else send to Balance Check and abort eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c) eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c) eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c) eflx_gnet(p) = eflx_gnet(p) + errsoi(c) if (abs(errsoi(c)) > 1.e-3_r8) then - write(iulog,*)'errsoi incorporated into sensible heat in LakeTemperature: c, (W/m^2):', c, errsoi(c) + print *, 'errsoi incorporated into sensible heat in LakeTemperature: c, (W/m^2):', c, errsoi(c) end if errsoi(c) = 0._r8 end if - end do ! This loop assumes only one point per column. ! lake_icethick diagnostic. - do j = 1, nlevlak - do fc = 1, num_lakec - c = filter_lakec(fc) - - if (j == 1) lake_icethick(c) = 0._r8 - - lake_icethick(c) = lake_icethick(c) + lake_icefrac(c,j)*dz_lake(c,j)*denh2o/denice - ! Convert from nominal to physical thickness + !$acc parallel loop independent gang worker default(present) private(sum1) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8 + !$acc loop vector reduction(+:sum1) + do j = 1, nlevlak + ! Convert from nominal to physical thickness + sum1 = sum1 + lake_icefrac(c,j)*dz_lake(c,j)*denh2o/denice end do + lake_icethick(c) = sum1 end do - + !$acc exit data delete(& + !!!! !$acc beta(1:num_lakec), & + !$acc a(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc b(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc c1(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc r(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc rhow(1:num_lakec,1:nlevlak) ,& + !$acc phi(1:num_lakec,1:nlevlak),& + !$acc kme(1:num_lakec,1:nlevlak) ,& + !$acc phi_soil(1:num_lakec) ,& + !$acc fin(1:num_lakec) ,& + !$acc ocvts(1:num_lakec) ,& + !$acc ncvts(1:num_lakec) ,& + !$acc tav_froz(1:num_lakec) ,& + !$acc tav_unfr(1:num_lakec) ,& + !$acc nav(1:num_lakec) ,& + !$acc iceav(1:num_lakec) ,& + !$acc qav(1:num_lakec) ,& + !$acc jtop(1:num_lakec) ,& + !$acc cv(1:num_lakec,-nlevsno+1:nlevgrnd) ,& + !$acc tk(1:num_lakec,-nlevsno+1:nlevgrnd) ,& + !$acc cv_lake(1:num_lakec,1:nlevlak) ,& + !$acc tk_lake(1:num_lakec,1:nlevlak) ,& + !$acc cvx (1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc tkix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc tx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc tktopsoillay(1:num_lakec) ,& + !$acc fnx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc phix(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd),& + !$acc zx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd) ,& + !$acc factx(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd), & + !$acc sabg_lyr_col(1:num_lakec,-nlevsno+1:1), & + !$acc jconvect(1:num_lakec), & + !$acc jconvectbot(1:num_lakec) ,& + !$acc bottomconvect(1:num_lakec) ,& + !$acc puddle(1:num_lakec) , & + !$acc frzn(1:num_lakec) ,zsum(1:num_lakec), & + !$acc gam(1:num_lakec,-nlevsno+1:nlevlak+nlevgrnd), & + !$acc lake_col_to_filter(bounds%begc:bounds%endc) ,& + !$acc cwat, cice_eff, cfus, tkice_eff, km ) + + !$acc exit data delete(temp,sum1,sum2,sum3, icesum) end associate end subroutine LakeTemperature @@ -1071,7 +1219,6 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso ! For lakes, the proper soil layers (not snow) should always be saturated. ! ! !USES: - !$acc routine seq use elm_varcon , only : denh2o, denice, tfrz, tkwat, tkice, tkair use elm_varcon , only : cpice, cpliq, thk_bedrock use elm_varpar , only : nlevsno, nlevsoi, nlevgrnd @@ -1080,9 +1227,9 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_lakec ! number of column lake points in column filter integer , intent(in) :: filter_lakec(:) ! column filter for lake points - real(r8) , intent(out) :: cv( bounds%begc: , -nlevsno+1: ) ! heat capacity [J/(m2 K)] [col, lev] - real(r8) , intent(out) :: tk( bounds%begc: , -nlevsno+1: ) ! thermal conductivity [W/(m K)] [col, lev] - real(r8) , intent(out) :: tktopsoillay( bounds%begc: ) ! thermal conductivity [W/(m K)] [col] + real(r8) , intent(out) :: cv( 1: , -nlevsno+1: ) ! heat capacity [J/(m2 K)] [col, lev] + real(r8) , intent(out) :: tk( 1: , -nlevsno+1: ) ! thermal conductivity [W/(m K)] [col, lev] + real(r8) , intent(out) :: tktopsoillay( 1: ) ! thermal conductivity [W/(m K)] [col] type(soilstate_type) , intent(in) :: soilstate_vars ! @@ -1094,7 +1241,7 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso real(r8) :: dke ! kersten number real(r8) :: fl ! fraction of liquid or unfrozen water to total water real(r8) :: satw ! relative total water content of soil. - real(r8) :: thk(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! thermal conductivity of layer + real(r8) :: thk(1:num_lakec,-nlevsno+1:nlevgrnd) ! thermal conductivity of layer real(r8) :: xicevol ! (virtual excess ice volume per nominal soil volume) !----------------------------------------------------------------------- @@ -1118,8 +1265,9 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso t_soisno => col_es%t_soisno & ! Input: [real(r8) (:,:)] soil temperature (Kelvin) ) + !$acc enter data create(thk(1:num_lakec,-nlevsno+1:nlevgrnd)) ! Thermal conductivity of soil from Farouki (1981) - + !$acc parallel loop independent gang vector collapse(2) default(present) private(c) do j = -nlevsno+1,nlevgrnd do fc = 1, num_lakec c = filter_lakec(fc) @@ -1142,12 +1290,12 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso dke = satw dksat = tkmg(c,j)*0.249_r8**(fl*watsat(c,j))*2.29_r8**watsat(c,j) endif - thk(c,j) = dke*dksat + (1._r8-dke)*tkdry(c,j) + thk(fc,j) = dke*dksat + (1._r8-dke)*tkdry(c,j) satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j)) ! Hydrology routine won't let the excess be liquid. if (satw > 1._r8) then xicevol = (satw-1._r8)*watsat(c,j) - thk(c,j) = (thk(c,j) + xicevol*tkice)/(1._r8 + xicevol)/(1._r8 + xicevol) + thk(fc,j) = (thk(fc,j) + xicevol*tkice)/(1._r8 + xicevol)/(1._r8 + xicevol) ! Use simple mean because excess ice is likely to be in chunks, thus conductivities add ! rather than the usual addition of resistances. ! Conductivity is reduced by the extra virtual volume fraction, as dz is not changing. @@ -1159,16 +1307,15 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso ! of the timestep or precise freezing trajectory. ! Does real sediment under lakes heave or drain? Could revisit later. elseif (j > nlevsoi) then - thk(c,j) = thk_bedrock + thk(fc,j) = thk_bedrock endif ! Thermal conductivity of snow, which from Jordan (1991) pp. 18 ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j) - thk(c,j) = tkair + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkair) + thk(fc,j) = tkair + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkair) end if - end do end do @@ -1178,32 +1325,34 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso ! For the first case, the snow layer conductivity for the middle of the layer will be returned. ! Because the interfaces are below the soil layers, the conductivity for the top soil layer ! will have to be returned separately. + !$acc parallel loop independent collapse(2) gang vector default(present) private(c) do j = -nlevsno+1,nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) if (j >= snl(c)+1 .AND. j <= nlevgrnd-1 .AND. j /= 0) then - tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & - /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) + tk(fc,j) = thk(fc,j)*thk(fc,j+1)*(z(c,j+1)-z(c,j)) & + /(thk(fc,j)*(z(c,j+1)-zi(c,j))+thk(fc,j+1)*(zi(c,j)-z(c,j))) else if (j == 0 .and. j >= snl(c)+1) then - tk(c,j) = thk(c,j) + tk(fc,j) = thk(fc,j) else if (j == nlevgrnd) then - tk(c,j) = 0._r8 + tk(fc,j) = 0._r8 end if ! For top soil layer. - if (j == 1) tktopsoillay(c) = thk(c,j) + if (j == 1) tktopsoillay(fc) = thk(fc,j) end do end do ! Soil heat capacity, from de Vires (1963) + !$acc parallel loop collapse(2) gang vector default(present) private(c) do j = 1, nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) - cv(c,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) + & + cv(fc,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) + & (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) ! if (j == 1) then ! if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then - ! cv(c,j) = cv(c,j) + cpice*h2osno(c) + ! cv(fc,j) = cv(fc,j) + cpice*h2osno(c) ! end if ! end if ! Won't worry about heat capacity for thin snow on lake with no snow layers. @@ -1212,23 +1361,25 @@ subroutine SoilThermProp_Lake (bounds, num_lakec, filter_lakec, tk, cv, tktopso end do ! Snow heat capacity - + !$acc parallel loop collapse(2) gang vector default(present) private(c) do j = -nlevsno+1,0 do fc = 1,num_lakec c = filter_lakec(fc) if (snl(c)+1 < 1 .and. j >= snl(c)+1) then - cv(c,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j) + cv(fc,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j) end if end do end do + !$acc exit data delete(thk(1:num_lakec,-nlevsno+1:nlevgrnd)) + end associate end subroutine SoilThermProp_Lake !----------------------------------------------------------------------- - subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs, & - energyflux_vars, lakestate_vars, dtime ) + subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, & + lakestate_vars, dtime ) ! ! !DESCRIPTION: ! Calculation of the phase change within snow, soil, & lake layers: @@ -1247,7 +1398,6 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs ! Errors will be trapped at the end of LakeTemperature. ! ! !USES: - !$acc routine seq use elm_varcon , only : tfrz, hfus, denh2o, denice, cpliq, cpice use elm_varpar , only : nlevsno, nlevgrnd, nlevlak ! @@ -1255,10 +1405,8 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_lakec ! number of lake columns integer , intent(in) :: filter_lakec(:) ! column filter for lake points - real(r8) , intent(inout) :: cv( bounds%begc: , -nlevsno+1: ) ! heat capacity [J/(m2 K)] [col, lev] - real(r8) , intent(inout) :: cv_lake( bounds%begc: , 1: ) ! heat capacity [J/(m2 K)] [col, levlak] - real(r8) , intent(out) :: lhabs( bounds%begc: ) ! total per-column latent heat abs. (J/m^2) [col] - type(energyflux_type) , intent(inout) :: energyflux_vars + real(r8) , intent(inout) :: cv( 1: , -nlevsno+1: ) ! heat capacity [J/(m2 K)] [col, lev] + real(r8) , intent(inout) :: cv_lake( 1: , 1: ) ! heat capacity [J/(m2 K)] [col, levlak] type(lakestate_type) , intent(inout) :: lakestate_vars real(r8), intent(in) :: dtime ! @@ -1268,7 +1416,6 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs real(r8) :: heatavail ! available energy for melting or freezing (J/m^2) real(r8) :: heatrem ! energy residual or loss after melting or freezing real(r8) :: melt ! actual melting (+) or freezing (-) [kg/m2] - !real(r8), parameter :: smallnumber = 1.e-7_r8 ! to prevent tiny residuals from rounding error real(r8), parameter :: smallnumber = 1.e-12_r8 ! The above actually was enough to cause a 0.1 W/m^2 energy imbalance ! when the bottom lake layer started freezing in a 50m Arctic lake logical :: dophasechangeflag @@ -1303,21 +1450,19 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs ! Initialization - + !$acc parallel loop independent gang vector default(present) do fc = 1,num_lakec c = filter_lakec(fc) - - qflx_snomelt(c) = 0._r8 - qflx_snomelt_lyr(c,:)= 0._r8 - eflx_snomelt(c) = 0._r8 - lhabs(c) = 0._r8 - qflx_snow_melt(c) = 0._r8 + qflx_snomelt(c) = 0._r8 + eflx_snomelt(c) = 0._r8 + qflx_snow_melt(c) = 0._r8 end do + !$acc parallel loop independent gang vector default(present) do j = -nlevsno+1,0 do fc = 1,num_lakec c = filter_lakec(fc) - + qflx_snomelt_lyr(c,j)= 0._r8 qflx_snofrz_lyr(c,j) = 0._r8 ! Do for all possible snow layers in case snl changes over timestep. ! Bug corrected ZMS 10/14/11 imelt(c,j) = 0 @@ -1325,19 +1470,17 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs end do ! Check for case of snow without snow layers and top lake layer temp above freezing. - + !$acc parallel loop independent gang vector default(present) private(c, melt) do fc = 1,num_lakec c = filter_lakec(fc) - if (snl(c) == 0 .and. h2osno(c) > 0._r8 .and. t_lake(c,1) > tfrz) then - heatavail = (t_lake(c,1) - tfrz) * cv_lake(c,1) + heatavail = (t_lake(c,1) - tfrz) * cv_lake(fc,1) melt = min(h2osno(c), heatavail/hfus) heatrem = max(heatavail - melt*hfus, 0._r8) !catch small negative value to keep t at tfrz - t_lake(c,1) = tfrz + heatrem/(cv_lake(c,1)) + t_lake(c,1) = tfrz + heatrem/(cv_lake(fc,1)) snow_depth(c) = snow_depth(c)*(1._r8 - melt/h2osno(c)) h2osno(c) = h2osno(c) - melt - lhabs(c) = lhabs(c) + melt*hfus qflx_snomelt(c) = qflx_snomelt(c) + melt/dtime qflx_snow_melt(c) = qflx_snow_melt(c) + melt/dtime ! Prevent tiny residuals @@ -1347,7 +1490,7 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs end do ! Lake phase change - + !$acc parallel loop independent gang vector collapse(2) default(present) private(c,melt,heatrem,dophasechangeflag) do j = 1,nlevlak do fc = 1,num_lakec c = filter_lakec(fc) @@ -1355,14 +1498,14 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs dophasechangeflag = .false. if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._r8) then ! melting dophasechangeflag = .true. - heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + heatavail = (t_lake(c,j) - tfrz) * cv_lake(fc,j) melt = min(lake_icefrac(c,j)*denh2o*dz_lake(c,j), heatavail/hfus) !denh2o is used because layer thickness is not adjusted for freezing heatrem = max(heatavail - melt*hfus, 0._r8) !catch small negative value to keep t at tfrz else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._r8) then !freezing dophasechangeflag = .true. - heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j) + heatavail = (t_lake(c,j) - tfrz) * cv_lake(fc,j) melt = max(-(1._r8-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus) !denh2o is used because layer thickness is not adjusted for freezing heatrem = min(heatavail - melt*hfus, 0._r8) @@ -1371,10 +1514,9 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs ! Update temperature and ice fraction. if (dophasechangeflag) then lake_icefrac(c,j) = lake_icefrac(c,j) - melt/(denh2o*dz_lake(c,j)) - lhabs(c) = lhabs(c) + melt*hfus ! Update heat capacity - cv_lake(c,j) = cv_lake(c,j) + melt*(cpliq-cpice) - t_lake(c,j) = tfrz + heatrem/cv_lake(c,j) + cv_lake(fc,j) = cv_lake(fc,j) + melt*(cpliq-cpice) + t_lake(c,j) = tfrz + heatrem/cv_lake(fc,j) ! Prevent tiny residuals if (lake_icefrac(c,j) > 1._r8 - smallnumber) lake_icefrac(c,j) = 1._r8 if (lake_icefrac(c,j) < smallnumber) lake_icefrac(c,j) = 0._r8 @@ -1384,7 +1526,7 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs ! Snow & soil phase change ! Currently, does not do freezing point depression. - + !$acc parallel loop independent gang vector default(present) collapse(2) private(c,melt,heatrem,dophasechangeflag) do j = -nlevsno+1,nlevgrnd do fc = 1,num_lakec c = filter_lakec(fc) @@ -1394,24 +1536,22 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._r8) then ! melting dophasechangeflag = .true. - heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + heatavail = (t_soisno(c,j) - tfrz) * cv(fc,j) melt = min(h2osoi_ice(c,j), heatavail/hfus) heatrem = max(heatavail - melt*hfus, 0._r8) !catch small negative value to keep t at tfrz if (j <= 0) then !snow imelt(c,j) = 1 qflx_snomelt(c) = qflx_snomelt(c) + melt/dtime - qflx_snomelt_lyr(c,j) = melt/dtime end if else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._r8) then !freezing dophasechangeflag = .true. - heatavail = (t_soisno(c,j) - tfrz) * cv(c,j) + heatavail = (t_soisno(c,j) - tfrz) * cv(fc,j) melt = max(-h2osoi_liq(c,j), heatavail/hfus) heatrem = min(heatavail - melt*hfus, 0._r8) !catch small positive value to keep t at tfrz if (j <= 0) then !snow imelt(c,j) = 2 - !qflx_snomelt(c) = qflx_snomelt(c) + melt ! Does this works for both signs of melt in SnowHydrology? I think ! qflx_snomelt(c) is just output. ! It looks like qflx_snomelt is just supposed to be positive. @@ -1424,10 +1564,9 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs if (dophasechangeflag) then h2osoi_ice(c,j) = h2osoi_ice(c,j) - melt h2osoi_liq(c,j) = h2osoi_liq(c,j) + melt - lhabs(c) = lhabs(c) + melt*hfus ! Update heat capacity - cv(c,j) = cv(c,j) + melt*(cpliq-cpice) - t_soisno(c,j) = tfrz + heatrem/cv(c,j) + cv(fc,j) = cv(fc,j) + melt*(cpliq-cpice) + t_soisno(c,j) = tfrz + heatrem/cv(fc,j) ! Prevent tiny residuals if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._r8 if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._r8 @@ -1438,10 +1577,13 @@ subroutine PhaseChange_Lake (bounds, num_lakec, filter_lakec, cv, cv_lake, lhabs end do ! Update eflx_snomelt(c) + !$acc parallel loop independent gang vector default(present) do fc = 1,num_lakec c = filter_lakec(fc) eflx_snomelt(c) = qflx_snomelt(c)*hfus end do + + !$acc parallel loop independent gang vector default(present) collapse(2) private(c) do j = -nlevsno+1,0 do fc = 1,num_lakec c = filter_lakec(fc) diff --git a/components/elm/src/biogeophys/PhotosynthesisMod.F90 b/components/elm/src/biogeophys/PhotosynthesisMod.F90 index aee433610da7..3b60693e160e 100644 --- a/components/elm/src/biogeophys/PhotosynthesisMod.F90 +++ b/components/elm/src/biogeophys/PhotosynthesisMod.F90 @@ -38,7 +38,6 @@ module PhotosynthesisMod use VegetationDataType , only : veg_wf, veg_ws use ColumnDataType , only : col_es, col_ws, col_wf use SoilStateType , only : soilstate_type - use WaterfluxType , only : waterflux_type ! implicit none save @@ -85,27 +84,19 @@ module PhotosynthesisMod integer, parameter, private :: stomatalcond_mtd_medlyn2011 = 2 ! Medlyn 2011 method for photosynthesis ! !PUBLIC VARIABLES: - !$acc declare copyin(sun ) - !$acc declare copyin(sha ) - !$acc declare copyin(xyl ) - !$acc declare copyin(root) - !$acc declare copyin(veg ) - !$acc declare copyin(soil) - !$acc declare copyin(stomatalcond_mtd_bb1987) - !$acc declare copyin(stomatalcond_mtd_medlyn2011) type :: photo_params_type - real(r8),pointer , public :: krmax (:) => null() + real(r8),pointer , public :: krmax (:) => null() real(r8),pointer , public :: kmax (:,:) => null() real(r8),pointer , public :: psi50 (:,:) => null() real(r8),pointer , public :: ck (:,:) => null() - real(r8),pointer , public :: psi_soil_ref (:) => null() + real(r8),pointer , public :: psi_soil_ref (:) => null() real(r8),pointer , public :: lmr_intercept_atkin(:) => null() contains procedure, private :: allocParams procedure, public :: readParams end type photo_params_type ! - type(photo_params_type), public, protected :: params_inst ! params_inst is populated in readParamsMod + type(photo_params_type), public :: params_inst ! params_inst is populated in readParamsMod !$acc declare create(params_inst) contains @@ -207,12 +198,14 @@ subroutine readParams ( this, ncid ) end subroutine readParams - !------------------------------------------------------------------------------ - subroutine Photosynthesis ( bounds, fn, filterp, & + subroutine Photosynthesis ( bounds, fn, filterp,converged, & esat_tv, eair, oair, cair, rb, btran, & - dayl_factor, atm2lnd_vars, surfalb_vars, solarabs_vars, & - canopystate_vars, photosyns_vars, phase) + dayl_factor, surfalb_vars, solarabs_vars, & + canopystate_vars, photosyns_vars, phase, & + par_z, lai_z, vcmaxcint, alphapsn, & + ci_z, rs, rs_z, lmr, lmr_z, psn, & + psn_z, psn_wc, psn_wj, psn_wp) ! ! !DESCRIPTION: ! Leaf photosynthesis and stomatal conductance calculation as described by @@ -222,38 +215,52 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! Note: This subroutine is not called via FATES (RGK) ! ! !USES: - !$acc routine seq use elm_varcon , only : rgas, tfrz use elm_varctl , only : carbon_only use pftvarcon , only : vcmax_np1, vcmax_np2, vcmax_np3, vcmax_np4, jmax_np1, jmax_np2, jmax_np3 ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: fn ! size of pft filter - integer , intent(in) :: filterp(fn) ! patch filter - real(r8) , intent(in) :: esat_tv( bounds%begp: ) ! saturation vapor pressure at t_veg (Pa) [pft] - real(r8) , intent(in) :: eair( bounds%begp: ) ! vapor pressure of canopy air (Pa) [pft] - real(r8) , intent(in) :: oair( bounds%begp: ) ! Atmospheric O2 partial pressure (Pa) [pft] - real(r8) , intent(in) :: cair( bounds%begp: ) ! Atmospheric CO2 partial pressure (Pa) [pft] - real(r8) , intent(in) :: rb( bounds%begp: ) ! boundary layer resistance (s/m) [pft] - real(r8) , intent(in) :: btran( bounds%begp: ) ! transpiration wetness factor (0 to 1) [pft] - real(r8) , intent(in) :: dayl_factor( bounds%begp: ) ! scalar (0-1) for daylength - type(atm2lnd_type) , intent(inout) :: atm2lnd_vars - type(surfalb_type) , intent(inout) :: surfalb_vars - type(solarabs_type) , intent(inout) :: solarabs_vars - type(canopystate_type) , intent(inout) :: canopystate_vars - type(photosyns_type) , intent(inout) :: photosyns_vars - character(len=3) , intent(in) :: phase ! 'sun' or 'sha' + integer , intent(in) :: fn ! size of pft filter + integer , intent(in) :: filterp(1:fn) ! patch filter + integer , intent(in) :: converged(1:fn) + real(r8) , intent(in) :: esat_tv( 1:fn ) ! saturation vapor pressure at t_veg (Pa) [pft] + real(r8) , intent(in) :: eair(1:fn) ! vapor pressure of canopy air (Pa) [pft] + real(r8) , intent(in) :: oair(1:fn) ! Atmospheric O2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: cair(1:fn) ! Atmospheric CO2 partial pressure (Pa) [pft] + real(r8) , intent(in) :: rb( 1:fn ) ! boundary layer resistance (s/m) [pft] + real(r8) , intent(in) :: btran( bounds%begp: )! transpiration wetness factor (0 to 1) [pft] + real(r8) , intent(in) :: dayl_factor( 1:fn ) ! scalar (0-1) for daylength + type(surfalb_type) , intent(inout) :: surfalb_vars + type(solarabs_type) , intent(inout) :: solarabs_vars + type(canopystate_type) , intent(inout) :: canopystate_vars + type(photosyns_type) , intent(inout) :: photosyns_vars + character(len=3) , intent(in) :: phase ! 'sun' or 'sha' + !!passing these variables as arguments to avoid deep copying the local pointers to GPU + real(r8), intent(in) :: par_z (bounds%begp:,:) ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) + real(r8), intent(in) :: lai_z (bounds%begp:,:) ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded + real(r8), intent(in) :: vcmaxcint(bounds%begp:) ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient + real(r8), intent(inout) :: alphapsn (bounds%begp:) ! Output: [real(r8) (:) ] 13C fractionation factor for PSN () + real(r8), intent(inout) :: ci_z (bounds%begp:,:) ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) + real(r8), intent(inout) :: rs (bounds%begp:) ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) + real(r8), intent(inout) :: rs_z (bounds%begp:,:) ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) + real(r8), intent(inout) :: lmr (bounds%begp:) ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(inout) :: lmr_z (bounds%begp:,:) ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) + real(r8), intent(inout) :: psn (bounds%begp:) ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] + real(r8), intent(inout) :: psn_z (bounds%begp:,:) ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] + real(r8), intent(inout) :: psn_wc(bounds%begp:) ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + real(r8), intent(inout) :: psn_wj(bounds%begp:) ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] + real(r8), intent(inout) :: psn_wp(bounds%begp:) ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] ! ! !LOCAL VARIABLES: ! ! Leaf photosynthesis parameters - real(r8) :: jmax_z(bounds%begp:bounds%endp,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) - real(r8) :: lnc(bounds%begp:bounds%endp) ! leaf N concentration (gN leaf/m^2) - real(r8) :: bbbopt(bounds%begp:bounds%endp)! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) - real(r8) :: mbbopt(bounds%begp:bounds%endp)! Ball-Berry slope of conductance-photosynthesis relationship, unstressed - real(r8) :: kn(bounds%begp:bounds%endp) ! leaf nitrogen decay coefficient + real(r8) :: jmax_z(1:fn,nlevcan) ! maximum electron transport rate (umol electrons/m**2/s) + real(r8) :: lnc(1:fn) ! leaf N concentration (gN leaf/m^2) + real(r8) :: bbbopt ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + ! real(r8) :: mbbopt(1:fn)! Ball-Berry slope of conductance-photosynthesis relationship, unstressed + real(r8) :: kn(1:fn) ! leaf nitrogen decay coefficient real(r8) :: vcmax25top ! canopy top: maximum rate of carboxylation at 25C (umol CO2/m**2/s) real(r8) :: jmax25top ! canopy top: maximum electron transport rate at 25C (umol electrons/m**2/s) real(r8) :: tpu25top ! canopy top: triose phosphate utilization rate at 25C (umol CO2/m**2/s) @@ -273,7 +280,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & real(r8) :: jmaxha ! activation energy for jmax (J/mol) real(r8) :: tpuha ! activation energy for tpu (J/mol) real(r8) :: lmrha ! activation energy for lmr (J/mol) - real(r8) :: kcha ! activation energy for kc (J/mol) + ! real(r8) :: kcha ! activation energy for kc (J/mol) real(r8) :: koha ! activation energy for ko (J/mol) real(r8) :: cpha ! activation energy for cp (J/mol) @@ -292,15 +299,14 @@ subroutine Photosynthesis ( bounds, fn, filterp, & real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) real(r8) :: lmrc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: fnps ! fraction of light absorbed by non-photosynthetic pigments - real(r8) :: theta_psii ! empirical curvature parameter for electron transport rate - - real(r8) :: theta_ip ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8), parameter :: fnps = 0.15_r8 ! fraction of light absorbed by non-photosynthetic pigments + real(r8), parameter :: theta_psii = 0.7_r8 ! empirical curvature parameter for electron transport rate + real(r8), parameter :: theta_ip = 0.95_r8 ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8), parameter :: rsmax0 = 2.e4_r8 ! maximum stomatal resistance [s/m] ! Other integer :: f,p,c,t,iv ! indices real(r8) :: cf ! s m**2/umol -> s/m - real(r8) :: rsmax0 ! maximum stomatal resistance [s/m] real(r8) :: gb ! leaf boundary layer conductance (m/s) real(r8) :: cs ! CO2 partial pressure at leaf surface (Pa) real(r8) :: gs ! leaf stomatal conductance (m/s) @@ -325,9 +331,9 @@ subroutine Photosynthesis ( bounds, fn, filterp, & real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: psn_wc_z(bounds%begp:bounds%endp,nlevcan) ! Rubisco-limited contribution to psn_z (umol CO2/m**2/s) - real(r8) :: psn_wj_z(bounds%begp:bounds%endp,nlevcan) ! RuBP-limited contribution to psn_z (umol CO2/m**2/s) - real(r8) :: psn_wp_z(bounds%begp:bounds%endp,nlevcan) ! product-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wc_z(1:fn,nlevcan) ! Rubisco-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wj_z(1:fn,nlevcan) ! RuBP-limited contribution to psn_z (umol CO2/m**2/s) + real(r8) :: psn_wp_z(1:fn,nlevcan) ! product-limited contribution to psn_z (umol CO2/m**2/s) real(r8) :: psncan ! canopy sum of psn_z real(r8) :: psncan_wc ! canopy sum of psn_wc_z @@ -338,45 +344,29 @@ subroutine Photosynthesis ( bounds, fn, filterp, & real(r8) :: laican ! canopy sum of lai_z real(r8) :: rh_can - real(r8) , pointer :: lai_z (:,:) - real(r8) , pointer :: par_z (:,:) - real(r8) , pointer :: vcmaxcint (:) - real(r8) , pointer :: alphapsn (:) - real(r8) , pointer :: psn (:) - real(r8) , pointer :: psn_wc (:) - real(r8) , pointer :: psn_wj (:) - real(r8) , pointer :: psn_wp (:) - real(r8) , pointer :: psn_z (:,:) - real(r8) , pointer :: lmr (:) - real(r8) , pointer :: lmr_z (:,:) - real(r8) , pointer :: rs (:) - real(r8) , pointer :: rs_z (:,:) - real(r8) , pointer :: ci_z (:,:) - real(r8) , pointer :: alphapsnsun (:) - real(r8) , pointer :: alphapsnsha (:) - - real(r8) :: lpc(bounds%begp:bounds%endp) ! leaf P concentration (gP leaf/m^2) + + real(r8) :: lpc ! leaf P concentration (gP leaf/m^2) real(r8) :: sum_nscaler real(r8) :: total_lai - integer :: rad_layers_patch + integer :: rad_layers_patch,i_type !------------------------------------------------------------------------------ ! Temperature and soil water response functions + !------------------------------------------------------------------------------ + associate( & + c3psn => veg_vp%c3psn , & ! Input: [real(r8) (:) ] photosynthetic pathway: 0. = c4, 1. = c3 + leafcn => veg_vp%leafcn , & ! Input: [real(r8) (:) ] leaf C:N (gC/gN) + flnr => veg_vp%flnr , & ! Input: [real(r8) (:) ] fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) + fnitr => veg_vp%fnitr , & ! Input: [real(r8) (:) ] foliage nitrogen limitation factor (-) + slatop => veg_vp%slatop , & ! Input: [real(r8) (:) ] specific leaf area at top of canopy, projected area basis [m^2/gC] - associate( & - c3psn => veg_vp%c3psn , & ! Input: [real(r8) (:) ] photosynthetic pathway: 0. = c4, 1. = c3 - leafcn => veg_vp%leafcn , & ! Input: [real(r8) (:) ] leaf C:N (gC/gN) - flnr => veg_vp%flnr , & ! Input: [real(r8) (:) ] fraction of leaf N in the Rubisco enzyme (gN Rubisco / gN leaf) - fnitr => veg_vp%fnitr , & ! Input: [real(r8) (:) ] foliage nitrogen limitation factor (-) - slatop => veg_vp%slatop , & ! Input: [real(r8) (:) ] specific leaf area at top of canopy, projected area basis [m^2/gC] - - forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) t_veg => veg_es%t_veg , & ! Input: [real(r8) (:) ] vegetation temperature (Kelvin) t10 => veg_es%t_a10 , & ! Input: [real(r8) (:) ] 10-day running mean of the 2 m temperature (K) tgcm => veg_es%thm , & ! Input: [real(r8) (:) ] air temperature at agcm reference height (kelvin) - nrad => surfalb_vars%nrad_patch , & ! Input: [integer (:) ] pft number of canopy layers, above snow for radiative transfer - tlai_z => surfalb_vars%tlai_z_patch , & ! Input: [real(r8) (:,:) ] pft total leaf area index for canopy layer + nrad => surfalb_vars%nrad_patch , & ! Input: [integer (:) ] pft number of canopy layers, above snow for radiative transfer + tlai_z => surfalb_vars%tlai_z_patch , & ! Input: [real(r8) (:,:) ] pft total leaf area index for canopy layer c3flag => photosyns_vars%c3flag_patch , & ! Output: [logical (:) ] true if C3 and false if C4 ac => photosyns_vars%ac_patch , & ! Output: [real(r8) (:,:) ] Rubisco-limited gross photosynthesis (umol CO2/m**2/s) @@ -402,125 +392,71 @@ subroutine Photosynthesis ( bounds, fn, filterp, & leafn => veg_ns%leafn , & leafn_storage => veg_ns%leafn_storage , & leafn_xfer => veg_ns%leafn_xfer , & - leafp => veg_ps%leafp , & - leafp_storage => veg_ps%leafp_storage , & - leafp_xfer => veg_ps%leafp_xfer , & - i_vcmax => veg_vp%i_vc , & - s_vcmax => veg_vp%s_vc & + leafp => veg_ps%leafp , & + leafp_storage => veg_ps%leafp_storage , & + leafp_xfer => veg_ps%leafp_xfer , & + i_vcmax => veg_vp%i_vc , & + s_vcmax => veg_vp%s_vc & ) - if (phase == 'sun') then !sun - par_z => solarabs_vars%parsun_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) - lai_z => canopystate_vars%laisun_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded - vcmaxcint => surfalb_vars%vcmaxcintsun_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient - alphapsn => photosyns_vars%alphapsnsun_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () - ci_z => photosyns_vars%cisun_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) - rs => photosyns_vars%rssun_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) - rs_z => photosyns_vars%rssun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) - lmr => photosyns_vars%lmrsun_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) - lmr_z => photosyns_vars%lmrsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) - psn => photosyns_vars%psnsun_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_z => photosyns_vars%psnsun_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wc => photosyns_vars%psnsun_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wj => photosyns_vars%psnsun_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wp => photosyns_vars%psnsun_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - else if (phase == 'sha') then !shade - par_z => solarabs_vars%parsha_z_patch ! Input: [real(r8) (:,:) ] par absorbed per unit lai for canopy layer (w/m**2) - lai_z => canopystate_vars%laisha_z_patch ! Input: [real(r8) (:,:) ] leaf area index for canopy layer, sunlit or shaded - vcmaxcint => surfalb_vars%vcmaxcintsha_patch ! Input: [real(r8) (:) ] leaf to canopy scaling coefficient - alphapsn => photosyns_vars%alphapsnsha_patch ! Input: [real(r8) (:) ] 13C fractionation factor for PSN () - ci_z => photosyns_vars%cisha_z_patch ! Output: [real(r8) (:,:) ] intracellular leaf CO2 (Pa) - rs => photosyns_vars%rssha_patch ! Output: [real(r8) (:) ] leaf stomatal resistance (s/m) - rs_z => photosyns_vars%rssha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf stomatal resistance (s/m) - lmr => photosyns_vars%lmrsha_patch ! Output: [real(r8) (:) ] leaf maintenance respiration rate (umol CO2/m**2/s) - lmr_z => photosyns_vars%lmrsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: leaf maintenance respiration rate (umol CO2/m**2/s) - psn => photosyns_vars%psnsha_patch ! Output: [real(r8) (:) ] foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_z => photosyns_vars%psnsha_z_patch ! Output: [real(r8) (:,:) ] canopy layer: foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wc => photosyns_vars%psnsha_wc_patch ! Output: [real(r8) (:) ] Rubisco-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wj => photosyns_vars%psnsha_wj_patch ! Output: [real(r8) (:) ] RuBP-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - psn_wp => photosyns_vars%psnsha_wp_patch ! Output: [real(r8) (:) ] product-limited foliage photosynthesis (umol co2 /m**2/ s) [always +] - end if - - - - ! Enforce expected array sizes - !==============================================================================! ! Photosynthesis and stomatal conductance parameters, from: ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 !==============================================================================! + !$acc enter data create(fnr,act25,vcmaxha,jmaxha,tpuha,lmrha,vcmaxhd,jmaxhd,tpuhd,lmrhd,lmrse,lmrc) ! Miscellaneous parameters, from Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - - fnps = 0.15_r8 - theta_psii = 0.7_r8 - theta_ip = 0.95_r8 - + ! vcmax25 parameters, from CN + !$acc serial default(present) + p = filterp(1) + i_type = veg_pp%itype(p) + fnr = veg_vp%fnr(i_type) !7.16_r8 + act25 = veg_vp%act25(i_type) !3.6_r8 !umol/mgRubisco/min + + ! Convert rubisco activity units from umol/mgRubisco/min -> + ! umol/gRubisco/s + act25 = act25 * 1000.0_r8 / 60.0_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment + ! 15:271-282 + vcmaxha = veg_vp%vcmaxha(i_type) !72000._r8 + jmaxha = veg_vp%jmaxha(i_type) !50000._r8 + tpuha = veg_vp%tpuha(i_type) !72000._r8 + lmrha = veg_vp%lmrha(i_type) !46390._r8 + + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + vcmaxhd = veg_vp%vcmaxhd(i_type) !200000._r8 + jmaxhd = veg_vp%jmaxhd(i_type) !200000._r8 + tpuhd = veg_vp%tpuhd(i_type) !200000._r8 + lmrhd = veg_vp%lmrhd(i_type) !150650._r8 + lmrse = veg_vp%lmrse(i_type) !490._r8 + lmrc = fth25 (lmrhd, lmrse) + !$acc end serial + !$acc enter data create(jmax_z(:,:), lnc(:),kn(:),psn_wc_z(:,:),psn_wj_z(:,:), psn_wp_z(:,:) ) + + !$acc parallel loop independent gang vector default(present) private(p,c,t,i_type,kc25,ko25,sco,cp25) do f = 1, fn + if(converged(f)) cycle p = filterp(f) c = veg_pp%column(p) t = veg_pp%topounit(p) - - ! vcmax25 parameters, from CN - - fnr = veg_vp%fnr(veg_pp%itype(p)) !7.16_r8 - act25 = veg_vp%act25(veg_pp%itype(p)) !3.6_r8 !umol/mgRubisco/min - ! Convert rubisco activity units from umol/mgRubisco/min -> - ! umol/gRubisco/s - act25 = act25 * 1000.0_r8 / 60.0_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment - ! 15:271-282 - - kcha = veg_vp%kcha(veg_pp%itype(p)) !79430._r8 - koha = veg_vp%koha(veg_pp%itype(p)) !36380._r8 - cpha = veg_vp%cpha(veg_pp%itype(p)) !37830._r8 - vcmaxha = veg_vp%vcmaxha(veg_pp%itype(p)) !72000._r8 - jmaxha = veg_vp%jmaxha(veg_pp%itype(p)) !50000._r8 - tpuha = veg_vp%tpuha(veg_pp%itype(p)) !72000._r8 - lmrha = veg_vp%lmrha(veg_pp%itype(p)) !46390._r8 - - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - - vcmaxhd = veg_vp%vcmaxhd(veg_pp%itype(p)) !200000._r8 - jmaxhd = veg_vp%jmaxhd(veg_pp%itype(p)) !200000._r8 - tpuhd = veg_vp%tpuhd(veg_pp%itype(p)) !200000._r8 - lmrhd = veg_vp%lmrhd(veg_pp%itype(p)) !150650._r8 - lmrse = veg_vp%lmrse(veg_pp%itype(p)) !490._r8 - lmrc = fth25 (lmrhd, lmrse) - + i_type = veg_pp%itype(p) ! C3 or C4 photosynthesis logical variable - - if (nint(c3psn(veg_pp%itype(p))) == 1) then + if (nint(c3psn(i_type)) == 1) then c3flag(p) = .true. - else if (nint(c3psn(veg_pp%itype(p))) == 0) then + else if (nint(c3psn(i_type)) == 0) then c3flag(p) = .false. end if - - ! C3 and C4 dependent parameters - - if (c3flag(p)) then - qe(p) = veg_vp%qe(veg_pp%itype(p)) !0._r8 - theta_cj(p) = veg_vp%theta_cj(veg_pp%itype(p)) !0.98_r8 - bbbopt(p) = veg_vp%bbbopt(veg_pp%itype(p)) !10000._r8 - mbbopt(p) = veg_vp%mbbopt(veg_pp%itype(p)) !9._r8 - else - qe(p) = veg_vp%qe(veg_pp%itype(p)) !0.05_r8 - theta_cj(p) = veg_vp%theta_cj(veg_pp%itype(p)) !0.80_r8 - bbbopt(p) = veg_vp%bbbopt(veg_pp%itype(p)) !40000._r8 - mbbopt(p) = veg_vp%mbbopt(veg_pp%itype(p)) !4._r8 - end if - ! Soil water stress applied to Ball-Berry parameters - - bbb(p) = max (bbbopt(p)*btran(p), 1._r8) - mbb(p) = mbbopt(p) - + theta_cj(p) = veg_vp%theta_cj(i_type) !0.98_r8 + qe(p) = veg_vp%qe(i_type) + bbb(p) = max (veg_vp%bbbopt(i_type) * btran(p), 1._r8) + mbb(p) = veg_vp%mbbopt(i_type) ! kc, ko, cp, from: Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 ! ! kc25 = 404.9 umol/mol @@ -530,49 +466,50 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! Derive sco from cp and O2 using present-day O2 (0.209 mol/mol) and re-calculate ! cp to account for variation in O2 using cp = 0.5 O2 / sco ! - kc25 = (404.9_r8 / 1.e06_r8) * forc_pbot(t) ko25 = (278.4_r8 / 1.e03_r8) * forc_pbot(t) sco = 0.5_r8 * 0.209_r8 / (42.75_r8 / 1.e06_r8) - cp25 = 0.5_r8 * oair(p) / sco + cp25 = 0.5_r8 * oair(f) / sco - kc(p) = kc25 * ft(t_veg(p), kcha) - ko(p) = ko25 * ft(t_veg(p), koha) - cp(p) = cp25 * ft(t_veg(p), cpha) + kc(p) = kc25 * ft(t_veg(p), veg_vp%kcha(i_type) )!79430._r8 + ko(p) = ko25 * ft(t_veg(p), veg_vp%koha(i_type) )!36380._r8 + cp(p) = cp25 * ft(t_veg(p), veg_vp%cpha(i_type) )!37830._r8 end do - + ! Multi-layer parameters scaled by leaf nitrogen profile. ! Loop through each canopy layer to calculate nitrogen profile using ! cumulative lai at the midpoint of the layer - + + !$acc parallel loop independent gang vector default(present) present(& + !$acc btran(:),leafn(:),kp_z(:,:),lmr_z(:,:), par_z(:,:),nrad(:),vcmaxcint(:),& + !$acc vcmax_z(:,:),t10(:),leafp(:),tpu_z(:,:),tlai_z(:,:),alphapsn(:),c3flag(:)) do f = 1, fn + if(converged(f)) cycle p = filterp(f) + i_type = veg_pp%itype(p) if ( .not. nu_com_leaf_physiology) then ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - lnc(p) = 1._r8 / (slatop(veg_pp%itype(p)) * leafcn(veg_pp%itype(p))) + lnc(f) = 1._r8 / (slatop(i_type) * leafcn(i_type)) ! vcmax25 at canopy top, as in CN but using lnc at top of the canopy - vcmax25top = lnc(p) * flnr(veg_pp%itype(p)) * fnr * act25 * dayl_factor(p) + vcmax25top = lnc(f) * flnr(i_type) * fnr * act25 * dayl_factor(f) if (.not. use_cn) then - vcmax25top = vcmax25top * fnitr(veg_pp%itype(p)) - else - if ( Carbon_only ) vcmax25top = vcmax25top * fnitr(veg_pp%itype(p)) + vcmax25top = vcmax25top * fnitr(i_type) + else if ( Carbon_only ) then + vcmax25top = vcmax25top * fnitr(i_type) end if - ! Parameters derived from vcmax25top. Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of Experimental Botany 44:907-920. jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top else - ! leaf level nutrient control on photosynthesis rate added by Q. Zhu Aug 2015 - if ( Carbon_only .or. carbonphosphorus_only ) then - lnc(p) = 1._r8 / (slatop(veg_pp%itype(p)) * leafcn(veg_pp%itype(p))) - vcmax25top = lnc(p) * flnr(veg_pp%itype(p)) * fnr * act25 * dayl_factor(p) - vcmax25top = vcmax25top * fnitr(veg_pp%itype(p)) + lnc(f) = 1._r8 / (slatop(i_type) * leafcn(i_type)) + vcmax25top = lnc(f) * flnr(i_type) * fnr * act25 * dayl_factor(f) + vcmax25top = vcmax25top * fnitr(i_type) jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top else if ( carbonnitrogen_only ) then ! only N control, from Kattge 2009 Global Change Biology 15 (4), 976-991 @@ -581,6 +518,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & sum_nscaler = 0.0_r8 laican = 0.0_r8 total_lai = 0.0_r8 + !$acc loop seq do iv = 1, nrad(p) if (iv == 1) then laican = 0.5_r8 * tlai_z(p,iv) @@ -593,7 +531,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & if (nlevcan == 1) then nscaler = 1.0_r8 else if (nlevcan > 1) then - nscaler = exp(-kn(p) * laican) + nscaler = exp(-kn(f) * laican) end if sum_nscaler = sum_nscaler + nscaler end do @@ -602,13 +540,13 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! dividing by LAI to convert total leaf nitrogen ! from m2 ground to m2 leaf; dividing by sum_nscaler to ! convert total leaf N to leaf N at canopy top - lnc(p) = leafn(p) / (total_lai * sum_nscaler) - lnc(p) = min(max(lnc(p),0.25_r8),3.0_r8) ! based on doi: 10.1002/ece3.1173 + lnc(f) = leafn(p) / (total_lai * sum_nscaler) + lnc(f) = min(max(lnc(f),0.25_r8),3.0_r8) ! based on doi: 10.1002/ece3.1173 else - lnc(p) = 0.0_r8 + lnc(f) = 0.0_r8 end if - vcmax25top = (i_vcmax(veg_pp%itype(p)) + s_vcmax(veg_pp%itype(p)) * lnc(p)) * dayl_factor(p) + vcmax25top = (i_vcmax(i_type) + s_vcmax(i_type) * lnc(f)) * dayl_factor(f) jmax25top = (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrz),11._r8),35._r8)) * vcmax25top vcmax25top = min(max(vcmax25top, 10.0_r8), 150.0_r8) jmax25top = min(max(jmax25top, 10.0_r8), 250.0_r8) @@ -617,13 +555,12 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! nu_com_leaf_physiology is true, vcmax25, jmax25 is derived from leafn, leafp concentration ! Anthony Walker 2014 DOI: 10.1002/ece3.1173 - - if (veg_pp%active(p) .and. (veg_pp%itype(p) .ne. noveg)) then + if (veg_pp%active(p) .and. (i_type .ne. noveg)) then ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) sum_nscaler = 0.0_r8 laican = 0.0_r8 total_lai = 0.0_r8 - + !$acc loop seq do iv = 1, nrad(p) if (iv == 1) then laican = 0.5_r8 * tlai_z(p,iv) @@ -636,7 +573,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & if (nlevcan == 1) then nscaler = 1.0_r8 else if (nlevcan > 1) then - nscaler = exp(-kn(p) * laican) + nscaler = exp(-kn(f) * laican) end if sum_nscaler = sum_nscaler + nscaler end do @@ -645,24 +582,23 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! dividing by LAI to convert total leaf nitrogen ! from m2 ground to m2 leaf; dividing by sum_nscaler to ! convert total leaf N to leaf N at canopy top - lnc(p) = leafn(p) / (total_lai * sum_nscaler) - lpc(p) = leafp(p) / (total_lai * sum_nscaler) - lnc(p) = min(max(lnc(p),0.25_r8),3.0_r8) ! based on doi: 10.1002/ece3.1173 - lpc(p) = min(max(lpc(p),0.014_r8),0.85_r8) ! based on doi: 10.1002/ece3.1173 - vcmax25top = exp(vcmax_np1(veg_pp%itype(p)) + vcmax_np2(veg_pp%itype(p))*log(lnc(p)) + & - vcmax_np3(veg_pp%itype(p))*log(lpc(p)) + vcmax_np4(veg_pp%itype(p))*log(lnc(p))*log(lpc(p)))& - * dayl_factor(p) - jmax25top = exp(jmax_np1 + jmax_np2*log(vcmax25top) + jmax_np3*log(lpc(p))) * dayl_factor(p) + lnc(f) = leafn(p) / (total_lai * sum_nscaler) + lpc = leafp(p) / (total_lai * sum_nscaler) + lnc(f) = min(max(lnc(f),0.25_r8),3.0_r8) ! based on doi: 10.1002/ece3.1173 + lpc = min(max(lpc,0.014_r8),0.85_r8) ! based on doi: 10.1002/ece3.1173 + vcmax25top = exp(vcmax_np1(i_type) + vcmax_np2(i_type)*log(lnc(f)) + & + vcmax_np3(i_type)*log(lpc) + vcmax_np4(i_type)*log(lnc(f))*log(lpc ))& + * dayl_factor(f) + jmax25top = exp(jmax_np1 + jmax_np2*log(vcmax25top) + jmax_np3*log(lpc )) * dayl_factor(f) vcmax25top = min(max(vcmax25top, 10.0_r8), 150.0_r8) jmax25top = min(max(jmax25top, 10.0_r8), 250.0_r8) else - lnc(p) = 0.0_r8 - lpc(p) = 0.0_r8 + lnc(f) = 0.0_r8 vcmax25top = 0.0_r8 jmax25top = 0.0_r8 end if else - lnc(p) = 0.0_r8 + lnc(f) = 0.0_r8 vcmax25top = 0.0_r8 jmax25top = 0.0_r8 end if @@ -678,10 +614,10 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! But not used as defined here if using sun/shade big leaf code. Instead, ! will use canopy integrated scaling factors from SurfaceAlbedo. - if (dayl_factor(p) .eq. 0._r8) then - kn(p) = 0._r8 + if (dayl_factor(f) .eq. 0._r8) then + kn(f) = 0._r8 else - kn(p) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) + kn(f) = exp(0.00963_r8 * vcmax25top/dayl_factor(f) - 2.43_r8) end if if (use_cn) then @@ -701,8 +637,9 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! ! Then scale this value at the top of the canopy for canopy depth + !NOTE: This seems like a strange way to calc sqrt of Q10_mr?? lmr25top = 2.525e-6_r8 * (ParamsShareInst%Q10_mr ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc(p) / 12.e-06_r8 + lmr25top = lmr25top * lnc(f) / 12.e-06_r8 else ! Leaf maintenance respiration in proportion to vcmax25top @@ -717,6 +654,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! calculated every timestep. Others are calculated only if daytime laican = 0._r8 rad_layers_patch = nrad(p) + !$acc loop seq do iv = 1, rad_layers_patch ! Cumulative lai at middle of layer @@ -732,11 +670,10 @@ subroutine Photosynthesis ( bounds, fn, filterp, & nscaler = vcmaxcint(p) if (nu_com_leaf_physiology) nscaler = 1 else if (nlevcan > 1) then - nscaler = exp(-kn(p) * laican) + nscaler = exp(-kn(f) * laican) end if ! Maintenance respiration - lmr25 = lmr25top * nscaler if (c3flag(p)) then lmr_z(p,iv) = lmr25 * ft(t_veg(p), lmrha) * fth(t_veg(p), lmrhd, lmrse, lmrc) @@ -745,18 +682,18 @@ subroutine Photosynthesis ( bounds, fn, filterp, & lmr_z(p,iv) = lmr_z(p,iv) / (1._r8 + exp( 1.3_r8*(t_veg(p)-(tfrz+55._r8)) )) end if - if (par_z(p,iv) <= 0._r8) then ! night time - + if (par_z(p,iv) <= 0._r8) then ! night time + ! vcmax_z(p,iv) = 0._r8 - jmax_z(p,iv) = 0._r8 - tpu_z(p,iv) = 0._r8 - kp_z(p,iv) = 0._r8 - + jmax_z(f,iv) = 0._r8 + tpu_z(p,iv) = 0._r8 + kp_z(p,iv) = 0._r8 + ! if ( use_c13 ) then alphapsn(p) = 1._r8 end if - - else ! day time + ! + else ! day time vcmax25 = vcmax25top * nscaler jmax25 = jmax25top * nscaler @@ -764,7 +701,6 @@ subroutine Photosynthesis ( bounds, fn, filterp, & kp25 = kp25top * nscaler ! Adjust for temperature - vcmaxse = 668.39_r8 - 1.07_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) jmaxse = 659.70_r8 - 0.75_r8 * min(max((t10(p)-tfrz),11._r8),35._r8) tpuse = vcmaxse @@ -772,7 +708,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & jmaxc = fth25 (jmaxhd, jmaxse) tpuc = fth25 (tpuhd, tpuse) vcmax_z(p,iv) = vcmax25 * ft(t_veg(p), vcmaxha) * fth(t_veg(p), vcmaxhd, vcmaxse, vcmaxc) - jmax_z(p,iv) = jmax25 * ft(t_veg(p), jmaxha) * fth(t_veg(p), jmaxhd, jmaxse, jmaxc) + jmax_z(f,iv) = jmax25 * ft(t_veg(p), jmaxha) * fth(t_veg(p), jmaxhd, jmaxse, jmaxc) tpu_z(p,iv) = tpu25 * ft(t_veg(p), tpuha) * fth(t_veg(p), tpuhd, tpuse, tpuc) if (.not. c3flag(p)) then @@ -784,36 +720,37 @@ subroutine Photosynthesis ( bounds, fn, filterp, & kp_z(p,iv) = kp25 * 2._r8**((t_veg(p)-(tfrz+25._r8))/10._r8) end if - ! Adjust for soil water - vcmax_z(p,iv) = vcmax_z(p,iv) * btran(p) lmr_z(p,iv) = lmr_z(p,iv) * btran(p) ! output variable vcmax25_top(p) = vcmax25top end do ! canopy layer loop - end do ! patch loop - + end do ! patch loop !==============================================================================! ! Leaf-level photosynthesis and stomatal conductance !==============================================================================! - - rsmax0 = 2.e4_r8 - + + !$acc parallel loop independent gang vector default(present) present(& + !$acc c3flag(:),nrad(:),bbb(:),rh_leaf(:),ap(:,:),ac(:,:),ag(:,:),psn_z(:,:),& + !$acc rs_z(:,:),an(:,:),aj(:,:),ci_z(p,:)) do f = 1, fn + if(converged(f)) cycle p = filterp(f) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - - ! Leaf boundary layer conductance, umol/m**2/s + + !$acc loop seq + do iv = 1, nrad(p) + p = filterp(f) + c = veg_pp%column(p) + t = veg_pp%topounit(p) - cf = forc_pbot(t)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 - gb = 1._r8/rb(p) - gb_mol(p) = gb * cf + ! Leaf boundary layer conductance, umol/m**2/s + cf = forc_pbot(t)/(rgas*1.e-3_r8*tgcm(p))*1.e06_r8 + gb = 1._r8/rb(f) + gb_mol(p) = gb * cf - ! Loop through canopy layers (above snow). Only do calculations if daytime - do iv = 1, nrad(p) + ! Loop through canopy layers (above snow). Only do calculations if daytime if (par_z(p,iv) <= 0._r8) then ! night time @@ -823,9 +760,9 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ag(p,iv) = 0._r8 an(p,iv) = ag(p,iv) - lmr_z(p,iv) psn_z(p,iv) = 0._r8 - psn_wc_z(p,iv) = 0._r8 - psn_wj_z(p,iv) = 0._r8 - psn_wp_z(p,iv) = 0._r8 + psn_wc_z(f,iv) = 0._r8 + psn_wj_z(f,iv) = 0._r8 + psn_wp_z(f,iv) = 0._r8 rs_z(p,iv) = min(rsmax0, 1._r8/bbb(p) * cf) ci_z(p,iv) = 0._r8 rh_leaf(p) = 0._r8 @@ -833,51 +770,47 @@ subroutine Photosynthesis ( bounds, fn, filterp, & else ! day time !now the constraint is no longer needed, Jinyun Tang - ceair = min( eair(p), esat_tv(p) ) - rh_can = ceair / esat_tv(p) + ceair = min( eair(f), esat_tv(f) ) + rh_can = ceair / esat_tv(f) ! Electron transport rate for C3 plants. Convert par from W/m2 to ! umol photons/m**2/s using the factor 4.6 qabs = 0.5_r8 * (1._r8 - fnps) * par_z(p,iv) * 4.6_r8 aquad = theta_psii - bquad = -(qabs + jmax_z(p,iv)) - cquad = qabs * jmax_z(p,iv) + bquad = -(qabs + jmax_z(f,iv)) + cquad = qabs * jmax_z(f,iv) call quadratic (aquad, bquad, cquad, r1, r2) je = min(r1,r2) ! Iterative loop for ci beginning with initial guess - if (c3flag(p)) then - ci_z(p,iv) = 0.7_r8 * cair(p) + ci_z(p,iv) = 0.7_r8 * cair(f) else - ci_z(p,iv) = 0.4_r8 * cair(p) + ci_z(p,iv) = 0.4_r8 * cair(f) end if niter = 0 ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 ! Save old ci - ciold = ci_z(p,iv) !find ci and stomatal conductance - call hybrid(ciold, p, iv, c, t, gb_mol(p), je, cair(p), oair(p), & + call hybrid(ciold, p, iv, c, t, gb_mol(p), je, cair(f), oair(f), & lmr_z(p,iv), par_z(p,iv), rh_can, gs_mol(p,iv), niter, & - atm2lnd_vars, photosyns_vars) + photosyns_vars) ! End of ci iteration. Check for an < 0, in which case gs_mol = bbb - if (an(p,iv) < 0._r8) gs_mol(p,iv) = bbb(p) ! Final estimates for cs and ci (needed for early exit of ci iteration when an < 0) - cs = cair(p) - 1.4_r8/gb_mol(p) * an(p,iv) * forc_pbot(t) + cs = cair(f) - 1.4_r8/gb_mol(p) * an(p,iv) * forc_pbot(t) cs = max(cs,1.e-06_r8) - ci_z(p,iv) = cair(p) - an(p,iv) * forc_pbot(t) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) + ci_z(p,iv) = cair(f) - an(p,iv) * forc_pbot(t) * (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv)) ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) @@ -888,16 +821,16 @@ subroutine Photosynthesis ( bounds, fn, filterp, & psn_z(p,iv) = ag(p,iv) - psn_wc_z(p,iv) = 0._r8 - psn_wj_z(p,iv) = 0._r8 - psn_wp_z(p,iv) = 0._r8 + psn_wc_z(f,iv) = 0._r8 + psn_wj_z(f,iv) = 0._r8 + psn_wp_z(f,iv) = 0._r8 if (ac(p,iv) <= aj(p,iv) .and. ac(p,iv) <= ap(p,iv)) then - psn_wc_z(p,iv) = psn_z(p,iv) + psn_wc_z(f,iv) = psn_z(p,iv) else if (aj(p,iv) < ac(p,iv) .and. aj(p,iv) <= ap(p,iv)) then - psn_wj_z(p,iv) = psn_z(p,iv) + psn_wj_z(f,iv) = psn_z(p,iv) else if (ap(p,iv) < ac(p,iv) .and. ap(p,iv) < aj(p,iv)) then - psn_wp_z(p,iv) = psn_z(p,iv) + psn_wp_z(f,iv) = psn_z(p,iv) end if ! Make sure iterative solution is correct @@ -906,24 +839,21 @@ subroutine Photosynthesis ( bounds, fn, filterp, & write(iulog,*) 'Negative stomatal conductance:' write (iulog,*)'p,iv,gs_mol= ',p,iv,gs_mol(p,iv) call endrun(decomp_index=p, elmlevel=namep, msg=errmsg(__FILE__, __LINE__)) - stop end if ! Compare with Ball-Berry model: gs_mol = m * an * hs/cs p + b - hs = (gb_mol(p)*ceair + gs_mol(p,iv)*esat_tv(p)) / ((gb_mol(p)+gs_mol(p,iv))*esat_tv(p)) + hs = (gb_mol(p)*ceair + gs_mol(p,iv)*esat_tv(f)) / ((gb_mol(p)+gs_mol(p,iv))*esat_tv(f)) rh_leaf(p) = hs gs_mol_err = mbb(p)*max(an(p,iv), 0._r8)*hs/cs*forc_pbot(t) + bbb(p) - if (abs(gs_mol(p,iv)-gs_mol_err) > 1.e-01_r8) then - write(iulog,*) 'Ball-Berry error check - stomatal conductance error:' + print *, 'Ball-Berry error check - stomatal conductance error:' write (iulog,*) gs_mol(p,iv), gs_mol_err end if end if ! night or day if branch end do ! canopy layer loop end do ! patch loop - !==============================================================================! ! Canopy photosynthesis and stomatal conductance !==============================================================================! @@ -931,10 +861,12 @@ subroutine Photosynthesis ( bounds, fn, filterp, & ! Sum canopy layer fluxes and then derive effective leaf-level fluxes (per ! unit leaf area), which are used in other parts of the model. Here, laican ! sums to either laisun or laisha. - + !$acc parallel loop gang worker independent default(present) present(& + !$acc lai_z(:,:),nrad(:),rs_z(:,:),rs(:),psn_z(:,:),psn_wp(:),psn_wc(:),& + !$acc psn_wj(:),lmr(:),lmr_z(:,:),psn(:)) do f = 1, fn + if(converged(f)) cycle p = filterp(f) - psncan = 0._r8 psncan_wc = 0._r8 psncan_wj = 0._r8 @@ -942,13 +874,14 @@ subroutine Photosynthesis ( bounds, fn, filterp, & lmrcan = 0._r8 gscan = 0._r8 laican = 0._r8 + !$acc loop seq do iv = 1, nrad(p) psncan = psncan + psn_z(p,iv) * lai_z(p,iv) - psncan_wc = psncan_wc + psn_wc_z(p,iv) * lai_z(p,iv) - psncan_wj = psncan_wj + psn_wj_z(p,iv) * lai_z(p,iv) - psncan_wp = psncan_wp + psn_wp_z(p,iv) * lai_z(p,iv) + psncan_wc = psncan_wc + psn_wc_z(f,iv) * lai_z(p,iv) + psncan_wj = psncan_wj + psn_wj_z(f,iv) * lai_z(p,iv) + psncan_wp = psncan_wp + psn_wp_z(f,iv) * lai_z(p,iv) lmrcan = lmrcan + lmr_z(p,iv) * lai_z(p,iv) - gscan = gscan + lai_z(p,iv) / (rb(p)+rs_z(p,iv)) + gscan = gscan + lai_z(p,iv) / (rb(f)+rs_z(p,iv)) laican = laican + lai_z(p,iv) end do if (laican > 0._r8) then @@ -957,7 +890,7 @@ subroutine Photosynthesis ( bounds, fn, filterp, & psn_wj(p) = psncan_wj / laican psn_wp(p) = psncan_wp / laican lmr(p) = lmrcan / laican - rs(p) = laican / gscan - rb(p) + rs(p) = laican / gscan - rb(f) else psn(p) = 0._r8 psn_wc(p) = 0._r8 @@ -968,23 +901,24 @@ subroutine Photosynthesis ( bounds, fn, filterp, & end if end do + !$acc exit data delete(fnr,act25,vcmaxha,jmaxha,tpuha,lmrha,vcmaxhd,jmaxhd,tpuhd,lmrhd,lmrse,lmrc & + !$acc ,jmax_z(:,:), lnc(:), kn(:),psn_wc_z(:,:nlevcan),psn_wj_z(:,:nlevcan), psn_wp_z(:,:nlevcan) ) + end associate end subroutine Photosynthesis !------------------------------------------------------------------------------ subroutine PhotosynthesisTotal (fn, filterp, & - atm2lnd_vars, cnstate_vars, canopystate_vars, photosyns_vars) + cnstate_vars, canopystate_vars, photosyns_vars) ! Note: This subroutine is not called via FATES (RGK) - !$acc routine seq ! ! Determine total photosynthesis ! ! !ARGUMENTS: integer , intent(in) :: fn ! size of pft filter integer , intent(in) :: filterp(fn) ! patch filter - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(cnstate_type) , intent(in) :: cnstate_vars type(canopystate_type) , intent(in) :: canopystate_vars type(photosyns_type) , intent(inout) :: photosyns_vars @@ -1026,6 +960,7 @@ subroutine PhotosynthesisTotal (fn, filterp, & fpsn_wp => photosyns_vars%fpsn_wp_patch & ! Output: [real(r8) (:) ] product-limited photosynthesis (umol CO2 /m**2 /s) ) + !$acc parallel loop independent gang vector default(present) do f = 1, fn p = filterp(f) g = veg_pp%gridcell(p) @@ -1072,7 +1007,6 @@ subroutine Fractionation(bounds, fn, filterp, & ! limitation is taken into account in the CNAllocation module. ! ! !ARGUMENTS: - !$acc routine seq type(bounds_type) , intent(in ) :: bounds integer , intent(in ) :: fn ! size of pft filter integer , intent(in ) :: filterp(fn) ! patch filter @@ -1086,7 +1020,7 @@ subroutine Fractionation(bounds, fn, filterp, & real(r8) , pointer :: par_z (:,:) ! needed for backwards compatiblity real(r8) , pointer :: alphapsn (:) ! needed for backwards compatiblity integer :: f,p,c,t,g,iv ! indices - real(r8) :: co2(bounds%begp:bounds%endp) ! atmospheric co2 partial pressure (pa) + real(r8) :: co2 ! atmospheric co2 partial pressure (pa) real(r8) :: ci !------------------------------------------------------------------------------ @@ -1102,37 +1036,67 @@ subroutine Fractionation(bounds, fn, filterp, & an => photosyns_vars%an_patch , & ! Input: [real(r8) (:,:) ] net leaf photosynthesis (umol CO2/m**2/s) gb_mol => photosyns_vars%gb_mol_patch , & ! Input: [real(r8) (:) ] leaf boundary layer conductance (umol H2O/m**2/s) - gs_mol => photosyns_vars%gs_mol_patch & ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + gs_mol => photosyns_vars%gs_mol_patch , & ! Input: [real(r8) (:,:) ] leaf stomatal conductance (umol H2O/m**2/s) + par_z_sun => solarabs_vars%parsun_z_patch , & ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn_sun => photosyns_vars%alphapsnsun_patch , & ! Output: [real(r8) (:)] + par_z_sha => solarabs_vars%parsha_z_patch , & ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + alphapsn_sha => photosyns_vars%alphapsnsha_patch & ! Output: [real(r8) (:)] ) - if (phase == 1) then - par_z => solarabs_vars%parsun_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) - alphapsn => photosyns_vars%alphapsnsun_patch ! Output: [real(r8) (:)] - else if (phase == 0) then - par_z => solarabs_vars%parsha_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) - alphapsn => photosyns_vars%alphapsnsha_patch ! Output: [real(r8) (:)] - end if - - do f = 1, fn - p = filterp(f) - c = veg_pp%column(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) + ! if (phase == 1) then + ! par_z => solarabs_vars%parsun_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + ! alphapsn => photosyns_vars%alphapsnsun_patch ! Output: [real(r8) (:)] + ! else if (phase == 0) then + ! par_z => solarabs_vars%parsha_z_patch ! Input : [real(r8) (:,:)] par absorbed per unit lai for canopy layer (w/m**2) + ! alphapsn => photosyns_vars%alphapsnsha_patch ! Output: [real(r8) (:)] + ! end if - co2(p) = forc_pco2(t) + if( phase == 1) then + !$acc parallel loop independent gang vector collapse(2) default(present) do iv = 1,nrad(p) - if (par_z(p,iv) <= 0._r8) then ! night time - alphapsn(p) = 1._r8 - else ! day time - ci = co2(p) - ((an(p,iv) * (1._r8-downreg(p)) ) * & - forc_pbot(t) * & - (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) - alphapsn(p) = 1._r8 + (((c3psn(veg_pp%itype(p)) * & - (4.4_r8 + (22.6_r8*(ci/co2(p))))) + & - ((1._r8 - c3psn(veg_pp%itype(p))) * 4.4_r8))/1000._r8) - end if + do f = 1, fn + p = filterp(f) + c = veg_pp%column(p) + t = veg_pp%topounit(p) + g = veg_pp%gridcell(p) + + co2 = forc_pco2(t) + if (par_z_sun(p,iv) <= 0._r8) then ! night time + alphapsn_sun(p) = 1._r8 + else ! day time + ci = co2 - ((an(p,iv) * (1._r8-downreg(p)) ) * & + forc_pbot(t) * & + (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) + alphapsn_sun(p) = 1._r8 + (((c3psn(veg_pp%itype(p)) * & + (4.4_r8 + (22.6_r8*(ci/co2)))) + & + ((1._r8 - c3psn(veg_pp%itype(p))) * 4.4_r8))/1000._r8) + end if + end do end do - end do + else if (phase == 0) then + !$acc parallel loop independent gang vector collapse(2) default(present) + do iv = 1,nrad(p) + do f = 1, fn + p = filterp(f) + c = veg_pp%column(p) + t = veg_pp%topounit(p) + g = veg_pp%gridcell(p) + + co2 = forc_pco2(t) + if (par_z_sha(p,iv) <= 0._r8) then ! night time + alphapsn_sha(p) = 1._r8 + else ! day time + ci = co2 - ((an(p,iv) * (1._r8-downreg(p)) ) * & + forc_pbot(t) * & + (1.4_r8*gs_mol(p,iv)+1.6_r8*gb_mol(p)) / (gb_mol(p)*gs_mol(p,iv))) + + alphapsn_sha(p) = 1._r8 + (((c3psn(veg_pp%itype(p)) * & + (4.4_r8 + (22.6_r8*(ci/co2)))) + & + ((1._r8 - c3psn(veg_pp%itype(p))) * 4.4_r8))/1000._r8) + end if + end do + end do + end if end associate @@ -1140,23 +1104,21 @@ end subroutine Fractionation !------------------------------------------------------------------------------- subroutine hybrid(x0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z,& - rh_can, gs_mol,iter, & - atm2lnd_vars, photosyns_vars) + rh_can, gs_mol,iter, photosyns_vars) ! - !! DESCRIPTION: + ! DESCRIPTION: ! use a hybrid solver to find the root of equation ! f(x) = x- h(x), !we want to find x, s.t. f(x) = 0. !the hybrid approach combines the strength of the newton secant approach (find the solution domain) !and the bisection approach implemented with the Brent's method to guarrantee convergence. - ! - !! REVISION HISTORY: + ! REVISION HISTORY: !Dec 14/2012: created by Jinyun Tang ! - !!USES: + !USES: ! - !! ARGUMENTS: + ! ARGUMENTS: !$acc routine seq implicit none real(r8), intent(inout) :: x0 !initial guess and final value of the solution @@ -1170,7 +1132,6 @@ subroutine hybrid(x0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z,& integer, intent(in) :: p, iv, c, t ! pft, c3/c4, column, and topounit index real(r8), intent(out) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) integer, intent(out) :: iter !number of iterations used, for record only - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(photosyns_type), intent(inout) :: photosyns_vars ! !! LOCAL VARIABLES @@ -1184,7 +1145,7 @@ subroutine hybrid(x0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z,& real(r8) :: tol,minx,minf call ci_func(x0, f0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - atm2lnd_vars, photosyns_vars) + photosyns_vars) if(f0 == 0._r8)return @@ -1193,7 +1154,7 @@ subroutine hybrid(x0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z,& x1 = x0 * 0.99_r8 call ci_func(x1,f1, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - atm2lnd_vars, photosyns_vars) + photosyns_vars) if(f1==0._r8)then x0 = x1 @@ -1220,7 +1181,7 @@ subroutine hybrid(x0, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z,& x1 = x call ci_func(x1,f1, p, iv, c, t, gb_mol, je, cair, oair, lmr_z, par_z, rh_can, gs_mol, & - atm2lnd_vars, photosyns_vars) + photosyns_vars) if(f1 1) then - nscaler = exp(-kn(p) * laican) + nscaler = exp(-kn(f) * laican) end if sum_nscaler = sum_nscaler + nscaler end do @@ -2176,7 +2134,7 @@ subroutine PhotosynthesisHydraulicStress ( bounds, fn, filterp, & if (nlevcan == 1) then nscaler = 1.0_r8 else if (nlevcan > 1) then - nscaler = exp(-kn(p) * laican) + nscaler = exp(-kn(f) * laican) end if sum_nscaler = sum_nscaler + nscaler end do @@ -2224,9 +2182,9 @@ subroutine PhotosynthesisHydraulicStress ( bounds, fn, filterp, & ! will use canopy integrated scaling factors from SurfaceAlbedo. if (dayl_factor(p) .eq. 0._r8) then - kn(p) = 0._r8 + kn(f) = 0._r8 else - kn(p) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) + kn(f) = exp(0.00963_r8 * vcmax25top/dayl_factor(p) - 2.43_r8) end if @@ -2286,8 +2244,8 @@ subroutine PhotosynthesisHydraulicStress ( bounds, fn, filterp, & nscaler_sun = vcmaxcint_sun(p) nscaler_sha = vcmaxcint_sha(p) else if (nlevcan > 1) then - nscaler_sun = exp(-kn(p) * laican) - nscaler_sha = exp(-kn(p) * laican) + nscaler_sun = exp(-kn(f) * laican) + nscaler_sha = exp(-kn(f) * laican) end if ! Maintenance respiration diff --git a/components/elm/src/biogeophys/QSatMod.F90 b/components/elm/src/biogeophys/QSatMod.F90 index e6636bf6e979..511028c67178 100644 --- a/components/elm/src/biogeophys/QSatMod.F90 +++ b/components/elm/src/biogeophys/QSatMod.F90 @@ -68,7 +68,7 @@ subroutine QSat (T, p, es, esdT, qs, qsdT) ! Reference: Polynomial approximations from: ! Piotr J. Flatau, et al.,1992: Polynomial fits to saturation ! vapor pressure. Journal of Applied Meteorology, 31, 1507-1513. - ! + !$acc routine seq ! !USES: use shr_kind_mod , only: r8 => shr_kind_r8 use shr_const_mod, only: SHR_CONST_TKFRZ diff --git a/components/elm/src/biogeophys/RootBiophysMod.F90 b/components/elm/src/biogeophys/RootBiophysMod.F90 index 42a6b1e83152..59f856752912 100644 --- a/components/elm/src/biogeophys/RootBiophysMod.F90 +++ b/components/elm/src/biogeophys/RootBiophysMod.F90 @@ -16,7 +16,7 @@ module RootBiophysMod integer :: root_prof_method !select the type of root profile parameterization !-------------------------------------------------------------------------------------- - + !$acc declare create(root_prof_method) contains !-------------------------------------------------------------------------------------- @@ -35,13 +35,13 @@ subroutine init_vegrootfr(bounds, nlevsoi, nlevgrnd, nlev2bed, rootfr) ! !DESCRIPTION !initialize plant root profiles - ! + !$acc routine seq ! USES use shr_kind_mod , only : r8 => shr_kind_r8 - use shr_assert_mod , only : shr_assert + !use shr_assert_mod , only : shr_assert use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type - use abortutils , only : endrun + !use abortutils , only : endrun ! ! !ARGUMENTS: implicit none @@ -52,10 +52,10 @@ subroutine init_vegrootfr(bounds, nlevsoi, nlevgrnd, nlev2bed, rootfr) real(r8), intent(out):: rootfr(bounds%begp: , 1: ) ! ! ! !LOCAL VARIABLES: - character(len=32) :: subname = 'init_vegrootfr' ! subroutine name + !character(len=32) :: subname = 'init_vegrootfr' ! subroutine name !------------------------------------------------------------------------ - SHR_ASSERT_ALL((ubound(rootfr) == (/bounds%endp, nlevgrnd/)), errMsg(__FILE__, __LINE__)) + !SHR_ASSERT_ALL((ubound(rootfr) == (/bounds%endp, nlevgrnd/)), errMsg(__FILE__, __LINE__)) select case (root_prof_method) case (zeng_2001_root) @@ -68,7 +68,7 @@ subroutine init_vegrootfr(bounds, nlevsoi, nlevgrnd, nlev2bed, rootfr) !schenk and Jackson root, 2002, to be defined later !rootfr(bounds%begp:bounds%endp, 1 : ubj) = schenk2002_rootfr(bounds, ubj, pcolumn, ivt, zi) case default - call endrun(subname // ':: a root fraction function must be specified!') + !call endrun(subname // ':: a root fraction function must be specified!') end select rootfr(bounds%begp:bounds%endp,nlevsoi+1:nlevgrnd)=0._r8 @@ -80,7 +80,7 @@ function zeng2001_rootfr(bounds, ubj, njbed) result(rootfr) ! DESCRIPTION ! compute root profile for soil water uptake ! using equation from Zeng 2001, J. Hydrometeorology - ! + !$acc routine seq ! USES use shr_kind_mod , only : r8 => shr_kind_r8 use shr_assert_mod , only : shr_assert diff --git a/components/elm/src/biogeophys/SnowHydrologyMod.F90 b/components/elm/src/biogeophys/SnowHydrologyMod.F90 index da648f88ca2c..e36116e3e709 100644 --- a/components/elm/src/biogeophys/SnowHydrologyMod.F90 +++ b/components/elm/src/biogeophys/SnowHydrologyMod.F90 @@ -52,8 +52,6 @@ module SnowHydrologyMod ! Aerosol species indices: ! 1= hydrophillic (bulk model) or within-ice (modal model) black carbon ! 2= hydrophobic (bulk model) or external (modal model) black carbon -! ! 1= hydrophillic black carbon -! ! 2= hydrophobic black carbon ! 3= hydrophilic organic carbon ! 4= hydrophobic organic carbon ! 5= dust species 1 @@ -70,15 +68,6 @@ module SnowHydrologyMod real(r8), public, parameter :: scvng_fct_mlt_dst3 = 0.01_r8 ! scavenging factor for dust species 3 inclusion in meltwater [frc] real(r8), public, parameter :: scvng_fct_mlt_dst4 = 0.01_r8 ! scavenging factor for dust species 4 inclusion in meltwater [frc] - !$acc declare copyin(scvng_fct_mlt_bcphi) - !$acc declare copyin(scvng_fct_mlt_bcpho) - !$acc declare copyin(scvng_fct_mlt_ocphi) - !$acc declare copyin(scvng_fct_mlt_ocpho) - !$acc declare copyin(scvng_fct_mlt_dst1 ) - !$acc declare copyin(scvng_fct_mlt_dst2 ) - !$acc declare copyin(scvng_fct_mlt_dst3 ) - !$acc declare copyin(scvng_fct_mlt_dst4 ) - !----------------------------------------------------------------------- !H. Wang ++ ! "Rfast" parameters used by Flanner et al (2012, ACP) @@ -130,7 +119,6 @@ subroutine SnowWater(bounds, & ! to being called. ! ! !USES: - !$acc routine seq use elm_varcon , only : denh2o, denice, wimp, ssi use landunit_varcon , only : istsoil use AerosolMod , only : AerosolFluxes @@ -144,34 +132,33 @@ subroutine SnowWater(bounds, & integer , intent(in) :: filter_nosnowc(:) ! column filter for non-snow points type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(aerosol_type) , intent(inout) :: aerosol_vars - real(r8) :: dtime ! ! !LOCAL VARIABLES: integer :: g ! gridcell loop index integer :: c, j, fc, l ! do loop/array indices - real(r8) :: qin(bounds%begc:bounds%endc) ! water flow into the elmement (mm/s) - real(r8) :: qout(bounds%begc:bounds%endc) ! water flow out of the elmement (mm/s) - real(r8) :: qin_bc_phi (bounds%begc:bounds%endc) ! flux of hydrophilic BC into layer [kg] - real(r8) :: qout_bc_phi (bounds%begc:bounds%endc) ! flux of hydrophilic BC out of layer [kg] - real(r8) :: qin_bc_pho (bounds%begc:bounds%endc) ! flux of hydrophobic BC into layer [kg] - real(r8) :: qout_bc_pho (bounds%begc:bounds%endc) ! flux of hydrophobic BC out of layer [kg] - real(r8) :: qin_oc_phi (bounds%begc:bounds%endc) ! flux of hydrophilic OC into layer [kg] - real(r8) :: qout_oc_phi (bounds%begc:bounds%endc) ! flux of hydrophilic OC out of layer [kg] - real(r8) :: qin_oc_pho (bounds%begc:bounds%endc) ! flux of hydrophobic OC into layer [kg] - real(r8) :: qout_oc_pho (bounds%begc:bounds%endc) ! flux of hydrophobic OC out of layer [kg] - real(r8) :: qin_dst1 (bounds%begc:bounds%endc) ! flux of dust species 1 into layer [kg] - real(r8) :: qout_dst1 (bounds%begc:bounds%endc) ! flux of dust species 1 out of layer [kg] - real(r8) :: qin_dst2 (bounds%begc:bounds%endc) ! flux of dust species 2 into layer [kg] - real(r8) :: qout_dst2 (bounds%begc:bounds%endc) ! flux of dust species 2 out of layer [kg] - real(r8) :: qin_dst3 (bounds%begc:bounds%endc) ! flux of dust species 3 into layer [kg] - real(r8) :: qout_dst3 (bounds%begc:bounds%endc) ! flux of dust species 3 out of layer [kg] - real(r8) :: qin_dst4 (bounds%begc:bounds%endc) ! flux of dust species 4 into layer [kg] - real(r8) :: qout_dst4 (bounds%begc:bounds%endc) ! flux of dust species 4 out of layer [kg] + real(r8) :: qin (1:num_snowc) ! water flow into the elmement (mm/s) + real(r8) :: qout (1:num_snowc) ! water flow out of the elmement (mm/s) + real(r8) :: qin_bc_phi (1:num_snowc) ! flux of hydrophilic BC into layer [kg] + real(r8) :: qout_bc_phi (1:num_snowc) ! flux of hydrophilic BC out of layer [kg] + real(r8) :: qin_bc_pho (1:num_snowc) ! flux of hydrophobic BC into layer [kg] + real(r8) :: qout_bc_pho (1:num_snowc) ! flux of hydrophobic BC out of layer [kg] + real(r8) :: qin_oc_phi (1:num_snowc) ! flux of hydrophilic OC into layer [kg] + real(r8) :: qout_oc_phi (1:num_snowc) ! flux of hydrophilic OC out of layer [kg] + real(r8) :: qin_oc_pho (1:num_snowc) ! flux of hydrophobic OC into layer [kg] + real(r8) :: qout_oc_pho (1:num_snowc) ! flux of hydrophobic OC out of layer [kg] + real(r8) :: qin_dst1 (1:num_snowc) ! flux of dust species 1 into layer [kg] + real(r8) :: qout_dst1 (1:num_snowc) ! flux of dust species 1 out of layer [kg] + real(r8) :: qin_dst2 (1:num_snowc) ! flux of dust species 2 into layer [kg] + real(r8) :: qout_dst2 (1:num_snowc) ! flux of dust species 2 out of layer [kg] + real(r8) :: qin_dst3 (1:num_snowc) ! flux of dust species 3 into layer [kg] + real(r8) :: qout_dst3 (1:num_snowc) ! flux of dust species 3 out of layer [kg] + real(r8) :: qin_dst4 (1:num_snowc) ! flux of dust species 4 into layer [kg] + real(r8) :: qout_dst4 (1:num_snowc) ! flux of dust species 4 out of layer [kg] real(r8) :: wgdif ! ice mass after minus sublimation - real(r8) :: vol_liq(bounds%begc:bounds%endc,-nlevsno+1:0) ! partial volume of liquid water in layer - real(r8) :: vol_ice(bounds%begc:bounds%endc,-nlevsno+1:0) ! partial volume of ice lens in layer - real(r8) :: eff_porosity(bounds%begc:bounds%endc,-nlevsno+1:0) ! effective porosity = porosity - vol_ice - real(r8) :: mss_liqice(bounds%begc:bounds%endc,-nlevsno+1:0) ! mass of liquid+ice in a layer + real(r8) :: vol_liq(1:num_snowc,-nlevsno+1:0) ! partial volume of liquid water in layer + real(r8) :: vol_ice(1:num_snowc,-nlevsno+1:0) ! partial volume of ice lens in layer + real(r8) :: eff_porosity(1:num_snowc,-nlevsno+1:0) ! effective porosity = porosity - vol_ice + real(r8) :: mss_liqice(1:num_snowc,-nlevsno+1:0) ! mass of liquid+ice in a layer !----------------------------------------------------------------------- !mgf++ real(r8) :: refrzsnow ! re-frozen snow [kg m-2] @@ -203,7 +190,7 @@ subroutine SnowWater(bounds, & qflx_dew_grnd => col_wf%qflx_dew_grnd , & ! Input: [real(r8) (:) ] ground surface dew formation (mm H2O /s) [+] qflx_snow_melt => col_wf%qflx_snow_melt , & ! Output: [real(r8) (:) ] net snow melt qflx_top_soil => col_wf%qflx_top_soil , & ! Output: [real(r8) (:) ] net water input into soil from top (mm/s) -! qflx_snofrz_lyr => cwf%qflx_snofrz_lyr , & ! HW+++ snow freezing rate (col,lyr) [kg m-2 s-1] + ! qflx_snofrz_lyr => cwf%qflx_snofrz_lyr , & ! HW+++ snow freezing rate (col,lyr) [kg m-2 s-1] mflx_neg_snow_col_1d => col_wf%mflx_neg_snow_1d , & ! Output: [real(r8) (:) ] mass flux from top soil layer due to negative water content in snow layers (kg H2O /s) @@ -219,32 +206,55 @@ subroutine SnowWater(bounds, & begc => bounds%begc , & endc => bounds%endc & ) + !$acc enter data create(& + !$acc qin(:), & + !$acc qout(:), & + !$acc qin_bc_phi(:), & + !$acc qout_bc_phi(:), & + !$acc qin_bc_pho(:), & + !$acc qout_bc_pho(:), & + !$acc qin_oc_phi(:), & + !$acc qout_oc_phi(:), & + !$acc qin_oc_pho(:), & + !$acc qout_oc_pho(:), & + !$acc qin_dst1(:), & + !$acc qout_dst1(:), & + !$acc qin_dst2(:), & + !$acc qout_dst2(:), & + !$acc qin_dst3(:), & + !$acc qout_dst3(:), & + !$acc qin_dst4(:), & + !$acc qout_dst4(:), & + !$acc vol_liq(:,:), & + !$acc vol_ice(:,:), & + !$acc eff_porosity(:,:), & + !$acc mss_liqice(:,:)) - ! Determine model time step - dtime = dtime_mod ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the ! surface snow layer resulting from sublimation (frost) / evaporation (condense) - mflx_neg_snow_col_1d(:) = 0._r8 + !TODO: check where else this is needed + !mflx_neg_snow_col_1d(:) = 0._r8 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_snowc c = filter_snowc(fc) l=col_pp%landunit(c) if (do_capsnow(c) .and. .not. use_firn_percolation_and_compaction) then - wgdif = h2osoi_ice(c,snl(c)+1) - frac_sno_eff(c)*qflx_sub_snow(c)*dtime + wgdif = h2osoi_ice(c,snl(c)+1) - frac_sno_eff(c)*qflx_sub_snow(c)*dtime_mod h2osoi_ice(c,snl(c)+1) = wgdif if (wgdif < 0._r8) then h2osoi_ice(c,snl(c)+1) = 0._r8 h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif end if h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) & - - frac_sno_eff(c)*qflx_evap_grnd(c) * dtime + - frac_sno_eff(c)*qflx_evap_grnd(c) * dtime_mod else wgdif = h2osoi_ice(c,snl(c)+1) & - + frac_sno_eff(c) * (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime + + frac_sno_eff(c) * (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime_mod h2osoi_ice(c,snl(c)+1) = wgdif if (wgdif < 0._r8) then h2osoi_ice(c,snl(c)+1) = 0._r8 @@ -252,10 +262,11 @@ subroutine SnowWater(bounds, & end if h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + & frac_sno_eff(c) * (qflx_rain_grnd(c) + qflx_dew_grnd(c) & - - qflx_evap_grnd(c)) * dtime + - qflx_evap_grnd(c)) * dtime_mod end if ! if negative, reduce deeper layer's liquid water content sequentially if(h2osoi_liq(c,snl(c)+1) < 0._r8) then + !$acc loop seq do j = snl(c)+1, 1 wgdif=h2osoi_liq(c,j) if (wgdif >= 0._r8) exit @@ -263,7 +274,7 @@ subroutine SnowWater(bounds, & if (.not.(j+1 > 0 .and. use_vsfm)) then h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + wgdif else - mflx_neg_snow_col_1d(c-bounds%begc+1) = wgdif/dtime + mflx_neg_snow_col_1d(c-bounds%begc+1) = wgdif/dtime_mod endif enddo end if @@ -271,14 +282,15 @@ subroutine SnowWater(bounds, & ! Porosity and partial volume + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1, 0 do fc = 1, num_snowc c = filter_snowc(fc) if (j >= snl(c)+1) then ! need to scale dz by frac_sno to convert to grid cell average depth - vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*frac_sno_eff(c)*denice)) - eff_porosity(c,j) = 1._r8 - vol_ice(c,j) - vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*frac_sno_eff(c)*denh2o)) + vol_ice(fc,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*frac_sno_eff(c)*denice)) + eff_porosity(fc,j) = 1._r8 - vol_ice(fc,j) + vol_liq(fc,j) = min(eff_porosity(fc,j),h2osoi_liq(c,j)/(dz(c,j)*frac_sno_eff(c)*denh2o)) end if end do end do @@ -300,142 +312,147 @@ subroutine SnowWater(bounds, & ! 4) update mass of aerosol in top layer, accordingly ! 5) update mass concentration of aerosol accordingly - do c = bounds%begc,bounds%endc - qin(c) = 0._r8 - qin_bc_phi (c) = 0._r8 - qin_bc_pho (c) = 0._r8 - qin_oc_phi (c) = 0._r8 - qin_oc_pho (c) = 0._r8 - qin_dst1 (c) = 0._r8 - qin_dst2 (c) = 0._r8 - qin_dst3 (c) = 0._r8 - qin_dst4 (c) = 0._r8 + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_snowc + c = filter_snowc(fc) + qin(fc) = 0._r8 + qin_bc_phi(fc) = 0._r8 + qin_bc_pho(fc) = 0._r8 + qin_oc_phi(fc) = 0._r8 + qin_oc_pho(fc) = 0._r8 + qin_dst1(fc) = 0._r8 + qin_dst2(fc) = 0._r8 + qin_dst3(fc) = 0._r8 + qin_dst4(fc) = 0._r8 end do - do j = -nlevsno+1, 0 - do fc = 1, num_snowc - c = filter_snowc(fc) + !NOTE : look into qout race condition? + + !$acc parallel loop independent gang vector default(present) + do fc = 1, num_snowc + c = filter_snowc(fc) + !$acc loop seq + do j = -nlevsno+1, 0 if (j >= snl(c)+1) then - h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(fc) - mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(c) - mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(c) - mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(c) - mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(c) + mss_bcphi(c,j) = mss_bcphi(c,j) + qin_bc_phi(fc) + mss_bcpho(c,j) = mss_bcpho(c,j) + qin_bc_pho(fc) + mss_ocphi(c,j) = mss_ocphi(c,j) + qin_oc_phi(fc) + mss_ocpho(c,j) = mss_ocpho(c,j) + qin_oc_pho(fc) - mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(c) - mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(c) - mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(c) - mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(c) + mss_dst1(c,j) = mss_dst1(c,j) + qin_dst1(fc) + mss_dst2(c,j) = mss_dst2(c,j) + qin_dst2(fc) + mss_dst3(c,j) = mss_dst3(c,j) + qin_dst3(fc) + mss_dst4(c,j) = mss_dst4(c,j) + qin_dst4(fc) if (j <= -1) then ! No runoff over snow surface, just ponding on surface - if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then - qout(c) = 0._r8 + if (eff_porosity(fc,j) < wimp .OR. eff_porosity(fc,j+1) < wimp) then + qout(fc) = 0._r8 else ! dz must be scaled by frac_sno to obtain gridcell average value - qout(c) = max(0._r8,(vol_liq(c,j) & - - ssi*eff_porosity(c,j))*dz(c,j)*frac_sno_eff(c)) - qout(c) = min(qout(c),(1._r8-vol_ice(c,j+1) & - - vol_liq(c,j+1))*dz(c,j+1)*frac_sno_eff(c)) + qout(fc) = max(0._r8,(vol_liq(fc,j) & + - ssi*eff_porosity(fc,j))*dz(c,j)*frac_sno_eff(c)) + qout(fc) = min(qout(fc),(1._r8-vol_ice(fc,j+1) & + - vol_liq(fc,j+1))*dz(c,j+1)*frac_sno_eff(c)) end if else - qout(c) = max(0._r8,(vol_liq(c,j) & - - ssi*eff_porosity(c,j))*dz(c,j)*frac_sno_eff(c)) + qout(fc) = max(0._r8,(vol_liq(fc,j) & + - ssi*eff_porosity(fc,j))*dz(c,j)*frac_sno_eff(c)) end if - qout(c) = qout(c)*1000._r8 - h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c) - qin(c) = qout(c) + qout(fc) = qout(fc)*1000._r8 + h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(fc) + qin(fc) = qout(fc) ! mass of ice+water: in extremely rare circumstances, this can ! be zero, even though there is a snow layer defined. In ! this case, set the mass to a very small value to ! prevent division by zero. - mss_liqice(c,j) = h2osoi_liq(c,j)+h2osoi_ice(c,j) - if (mss_liqice(c,j) < 1E-30_r8) then - mss_liqice(c,j) = 1E-30_r8 + mss_liqice(fc,j) = h2osoi_liq(c,j)+h2osoi_ice(c,j) + if (mss_liqice(fc,j) < 1E-30_r8) then + mss_liqice(fc,j) = 1E-30_r8 endif ! BCPHI: ! 1. flux with meltwater: - qout_bc_phi(c) = qout(c)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice(c,j)) - if (qout_bc_phi(c) > mss_bcphi(c,j)) then - qout_bc_phi(c) = mss_bcphi(c,j) + qout_bc_phi(fc) = qout(fc)*scvng_fct_mlt_bcphi*(mss_bcphi(c,j)/mss_liqice(fc,j)) + if (qout_bc_phi(fc) > mss_bcphi(c,j)) then + qout_bc_phi(fc) = mss_bcphi(c,j) endif - mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(c) - qin_bc_phi(c) = qout_bc_phi(c) + mss_bcphi(c,j) = mss_bcphi(c,j) - qout_bc_phi(fc) + qin_bc_phi(fc) = qout_bc_phi(fc) ! BCPHO: ! 1. flux with meltwater: - qout_bc_pho(c) = qout(c)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice(c,j)) - if (qout_bc_pho(c) > mss_bcpho(c,j)) then - qout_bc_pho(c) = mss_bcpho(c,j) + qout_bc_pho(fc) = qout(fc)*scvng_fct_mlt_bcpho*(mss_bcpho(c,j)/mss_liqice(fc,j)) + if (qout_bc_pho(fc) > mss_bcpho(c,j)) then + qout_bc_pho(fc) = mss_bcpho(c,j) endif - mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(c) - qin_bc_pho(c) = qout_bc_pho(c) + mss_bcpho(c,j) = mss_bcpho(c,j) - qout_bc_pho(fc) + qin_bc_pho(fc) = qout_bc_pho(fc) ! OCPHI: ! 1. flux with meltwater: - qout_oc_phi(c) = qout(c)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice(c,j)) - if (qout_oc_phi(c) > mss_ocphi(c,j)) then - qout_oc_phi(c) = mss_ocphi(c,j) + qout_oc_phi(fc) = qout(fc)*scvng_fct_mlt_ocphi*(mss_ocphi(c,j)/mss_liqice(fc,j)) + if (qout_oc_phi(fc) > mss_ocphi(c,j)) then + qout_oc_phi(fc) = mss_ocphi(c,j) endif - mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(c) - qin_oc_phi(c) = qout_oc_phi(c) + mss_ocphi(c,j) = mss_ocphi(c,j) - qout_oc_phi(fc) + qin_oc_phi(fc) = qout_oc_phi(fc) ! OCPHO: ! 1. flux with meltwater: - qout_oc_pho(c) = qout(c)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice(c,j)) - if (qout_oc_pho(c) > mss_ocpho(c,j)) then - qout_oc_pho(c) = mss_ocpho(c,j) + qout_oc_pho(fc) = qout(fc)*scvng_fct_mlt_ocpho*(mss_ocpho(c,j)/mss_liqice(fc,j)) + if (qout_oc_pho(fc) > mss_ocpho(c,j)) then + qout_oc_pho(fc) = mss_ocpho(c,j) endif - mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(c) - qin_oc_pho(c) = qout_oc_pho(c) + mss_ocpho(c,j) = mss_ocpho(c,j) - qout_oc_pho(fc) + qin_oc_pho(fc) = qout_oc_pho(fc) ! DUST 1: ! 1. flux with meltwater: - qout_dst1(c) = qout(c)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice(c,j)) - if (qout_dst1(c) > mss_dst1(c,j)) then - qout_dst1(c) = mss_dst1(c,j) + qout_dst1(fc) = qout(fc)*scvng_fct_mlt_dst1*(mss_dst1(c,j)/mss_liqice(fc,j)) + if (qout_dst1(fc) > mss_dst1(c,j)) then + qout_dst1(fc) = mss_dst1(c,j) endif - mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(c) - qin_dst1(c) = qout_dst1(c) + mss_dst1(c,j) = mss_dst1(c,j) - qout_dst1(fc) + qin_dst1(fc) = qout_dst1(fc) ! DUST 2: ! 1. flux with meltwater: - qout_dst2(c) = qout(c)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice(c,j)) - if (qout_dst2(c) > mss_dst2(c,j)) then - qout_dst2(c) = mss_dst2(c,j) + qout_dst2(fc) = qout(fc)*scvng_fct_mlt_dst2*(mss_dst2(c,j)/mss_liqice(fc,j)) + if (qout_dst2(fc) > mss_dst2(c,j)) then + qout_dst2(fc) = mss_dst2(c,j) endif - mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(c) - qin_dst2(c) = qout_dst2(c) + mss_dst2(c,j) = mss_dst2(c,j) - qout_dst2(fc) + qin_dst2(fc) = qout_dst2(fc) ! DUST 3: ! 1. flux with meltwater: - qout_dst3(c) = qout(c)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice(c,j)) - if (qout_dst3(c) > mss_dst3(c,j)) then - qout_dst3(c) = mss_dst3(c,j) + qout_dst3(fc) = qout(fc)*scvng_fct_mlt_dst3*(mss_dst3(c,j)/mss_liqice(fc,j)) + if (qout_dst3(fc) > mss_dst3(c,j)) then + qout_dst3(fc) = mss_dst3(c,j) endif - mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(c) - qin_dst3(c) = qout_dst3(c) + mss_dst3(c,j) = mss_dst3(c,j) - qout_dst3(fc) + qin_dst3(fc) = qout_dst3(fc) ! DUST 4: ! 1. flux with meltwater: - qout_dst4(c) = qout(c)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice(c,j)) - if (qout_dst4(c) > mss_dst4(c,j)) then - qout_dst4(c) = mss_dst4(c,j) + qout_dst4(fc) = qout(fc)*scvng_fct_mlt_dst4*(mss_dst4(c,j)/mss_liqice(fc,j)) + if (qout_dst4(fc) > mss_dst4(c,j)) then + qout_dst4(fc) = mss_dst4(c,j) endif - mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(c) - qin_dst4(c) = qout_dst4(c) + mss_dst4(c,j) = mss_dst4(c,j) - qout_dst4(fc) + qin_dst4(fc) = qout_dst4(fc) end if end do end do - ! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layere - + ! Compute aerosol fluxes through snowpack and aerosol deposition fluxes into top layer call AerosolFluxes(bounds, num_snowc, filter_snowc, & atm2lnd_vars, aerosol_vars) @@ -445,6 +462,7 @@ subroutine SnowWater(bounds, & ! Layer interfaces (zi) and node depths (z) do not need adjustment here because they ! are adjusted in CombineSnowLayers and are not used up to that point. + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1, 0 do fc = 1, num_snowc c = filter_snowc(fc) @@ -454,17 +472,19 @@ subroutine SnowWater(bounds, & end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) ! Qout from snow bottom - qflx_snow_melt(c) = qflx_snow_melt(c) + (qout(c) / dtime) + qflx_snow_melt(c) = qflx_snow_melt(c) + (qout(fc) / dtime_mod) - qflx_top_soil(c) = (qout(c) / dtime) & + qflx_top_soil(c) = (qout(fc) / dtime_mod) & + (1.0_r8 - frac_sno_eff(c)) * qflx_rain_grnd(c) int_snow(c) = int_snow(c) + frac_sno_eff(c) & - * (qflx_dew_snow(c) + qflx_dew_grnd(c) + qflx_rain_grnd(c)) * dtime + * (qflx_dew_snow(c) + qflx_dew_grnd(c) + qflx_rain_grnd(c)) * dtime_mod end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nosnowc c = filter_nosnowc(fc) qflx_snow_melt(c) = qflx_snomelt(c) @@ -482,12 +502,13 @@ subroutine SnowWater(bounds, & ! state based on snow sublimation and re-freezing of liquid water. ! Re-freezing effect is inactived by default because of ! uncertainty in how this process operates. + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1, 0 do fc = 1, num_snowc c = filter_snowc(fc) if (j >= snl(c)+1) then !! snow that has re-frozen [kg/m2] - !refrzsnow = max(0._r8, (qflx_snofrz_lyr(c,j)*dtime)) + !refrzsnow = max(0._r8, (qflx_snofrz_lyr(c,j)*dtime_mod)) ! !! fraction of layer mass that is re-frozen !if ((h2osoi_liq(c,j) + h2osoi_ice(c,j)) > 0._r8) then @@ -498,7 +519,7 @@ subroutine SnowWater(bounds, & if (j == snl(c)+1) then ! snow that has sublimated [kg/m2] (top layer only) - subsnow = max(0._r8, (qflx_sub_snow(c)*dtime)) + subsnow = max(0._r8, (qflx_sub_snow(c)*dtime_mod)) ! fraction of layer mass that has sublimated: if ((h2osoi_liq(c,j) + h2osoi_ice(c,j)) > 0._r8) then @@ -536,13 +557,40 @@ subroutine SnowWater(bounds, & !mgf-- #endif + + + + !$acc exit data delete(& + !$acc qin(:), & + !$acc qout(:), & + !$acc qin_bc_phi(:), & + !$acc qout_bc_phi(:), & + !$acc qin_bc_pho(:), & + !$acc qout_bc_pho(:), & + !$acc qin_oc_phi(:), & + !$acc qout_oc_phi(:), & + !$acc qin_oc_pho(:), & + !$acc qout_oc_pho(:), & + !$acc qin_dst1(:), & + !$acc qout_dst1(:), & + !$acc qin_dst2(:), & + !$acc qout_dst2(:), & + !$acc qin_dst3(:), & + !$acc qout_dst3(:), & + !$acc qin_dst4(:), & + !$acc qout_dst4(:), & + !$acc vol_liq(:,:), & + !$acc vol_ice(:,:), & + !$acc eff_porosity(:,:), & + !$acc mss_liqice(:,:)) + end associate end subroutine SnowWater !----------------------------------------------------------------------- subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & - top_as_inst, dtime) + top_as, dtime) ! ! !DESCRIPTION: ! Determine the change in snow layer thickness due to compaction and @@ -554,7 +602,6 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & ! fraction after the melting versus before the melting. ! ! !USES: - !$acc routine seq use elm_varcon , only : denice, denh2o, tfrz, rpi, grav, rgas use landunit_varcon , only : istice_mec, istdlak, istsoil, istcrop use elm_varctl , only : subgridflag @@ -563,7 +610,7 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_snowc ! number of column snow points in column filter integer , intent(in) :: filter_snowc(:) ! column filter for snow points - type(topounit_atmospheric_state), intent(in) :: top_as_inst + type(topounit_atmospheric_state), intent(in) :: top_as real(r8), intent(in) :: dtime ! ! !LOCAL VARIABLES: @@ -581,9 +628,9 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & real(r8), parameter :: k_creep_firn = 3.7e-9_r8 ! Creep coefficient for firn (bi > 550 kg / m3) [m3-s/kg] ! real(r8) :: p_gls ! grain load stress [kg / m-s2] - real(r8) :: burden(bounds%begc:bounds%endc) ! pressure of overlying snow [kg/m2] - real(r8) :: zpseudo(bounds%begc:bounds%endc)! wind drift compaction / pseudo depth - logical :: mobile(bounds%begc:bounds%endc) ! current snow layer is mobile, i.e. susceptible to wind drift + real(r8) :: burden (1:num_snowc) ! pressure of overlying snow [kg/m2] + real(r8) :: zpseudo(1:num_snowc)! wind drift compaction / pseudo depth + logical :: mobile (1:num_snowc) ! current snow layer is mobile, i.e. susceptible to wind drift real(r8) :: snw_ssa ! Equivalent snow specific surface area [m2/kg] real(r8) :: ddz1_fresh ! Rate of settling of dendritic snowpack (Lehning et al., 2002) [1/s] real(r8) :: ddz1 ! Rate of settling of snowpack due to destructive metamorphism. @@ -599,6 +646,7 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & real(r8) :: bi ! partial density of ice [kg/m3] real(r8) :: wsum ! snowpack total water mass (ice+liquid) [kg/m2] real(r8) :: fsno_melt + real(r8) :: burden_noextra !----------------------------------------------------------------------- associate( & @@ -606,7 +654,7 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & n_melt => col_pp%n_melt , & ! Input: [real(r8) (:) ] SCA shape parameter ltype => lun_pp%itype , & ! Input: [integer (:) ] landunit type - forc_wind => top_as_inst%windbot , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) + forc_wind => top_as%windbot , & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) imelt => col_ef%imelt , & ! Input: [integer (:,:) ] flag for melting (=1), freezing (=2), Not=0 @@ -620,55 +668,44 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective snow grain radius (col,lyr) [microns, m^-6] dz => col_pp%dz & ! Output: [real(r8) (: ,:) ] layer depth (m) ) + !$acc enter data create(& + !$acc burden(:), & + !$acc zpseudo(:), & + !$acc mobile(:), & + !$acc ddz1_fresh, & + !$acc ddz1, & + !$acc ddz3, & + !$acc burden_noextra) ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0 - - if (use_firn_percolation_and_compaction) then + if( use_firn_percolation_and_compaction) then do fc = 1, num_snowc - c = filter_snowc(fc) - burden(c) = 0._r8 - zpseudo(c) = 0._r8 - mobile(c) = .true. + burden(fc) = 0._r8 + zpseudo(fc) = 0._r8 + mobile(fc) = .true. end do - else - burden(bounds%begc : bounds%endc) = 0._r8 - end if - do j = -nlevsno+1, 0 - do fc = 1, num_snowc - c = filter_snowc(fc) - if (use_firn_percolation_and_compaction) then - t = col_pp%topounit(c) - end if - if (j >= snl(c)+1) then - wx = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) - void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o)& - /(frac_sno(c) * dz(c,j)) - ! If void is negative, then increase dz such that void = 0. - ! This should be done for any landunit, but for now is done only for glacier_mec 1andunits. - - if (.not. use_firn_percolation_and_compaction) then - ! I don't think the next 5 lines are necessary (removed in CLMv5) - l = col_pp%landunit(c) - if (ltype(l) == istice_mec .and. void < 0._r8) then - dz(c,j) = h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o - void = 0._r8 - endif - endif + do j = -nlevsno+1, 0 + do fc = 1, num_snowc + c = filter_snowc(fc) + t = col_pp%topounit(c) + l = col_pp%landunit(c) + t = col_pp%topounit(c) + if (j >= snl(c)+1) then + + wx = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o)& + /(frac_sno(c) * dz(c,j)) - ! Allow compaction only for non-saturated node and higher ice lens node. - if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then - bi = h2osoi_ice(c,j) / (frac_sno(c) * dz(c,j)) - fi = h2osoi_ice(c,j) / wx - td = tfrz-t_soisno(c,j) - dexpf = exp(-c4*td) + bi = h2osoi_ice(c,j) / (frac_sno(c) * dz(c,j)) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) ! Settling as a result of destructive metamorphism - if (.not. use_firn_percolation_and_compaction) then - ddz1 = -c3*dexpf - if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm)) - else ddz1_fresh = (-grav * (burden(c) + wx/2._r8)) / & (0.007_r8 * min(max(bi,dm),denice)**(4.75_r8 + min(td,0._r8)/40._r8)) snw_ssa = 3.e6_r8 / (denice * snw_rds(c,j)) @@ -678,17 +715,12 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & ddz1 = -c3_ams*dexpf if (bi > rho_dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-rho_dm)) ddz1 = ddz1 + ddz1_fresh - endif - - ! Liquid water term + ! Liquid water term - if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)*frac_sno(c)) ddz1=ddz1*c5 + if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)*frac_sno(c)) ddz1=ddz1*c5 - ! Compaction due to overburden - if (.not. use_firn_percolation_and_compaction) then - ddz2 = -(burden(c)+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0 - else - p_gls = max(denice / bi, 1._r8) * grav * (burden(c) + wx/2._r8) + ! Compaction due to overburden + p_gls = max(denice / bi, 1._r8) * grav * (burden(fc) + wx/2._r8) if (bi <= 550._r8) then ! Low density, i.e. snow ddz2 = (-k_creep_snow * (max(denice / bi, 1._r8) - 1._r8) * & exp(-60.e6_r8 / (rgas * t_soisno(c,j))) * p_gls) / & @@ -700,44 +732,37 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & (snw_rds(c,j) * 1.e-6_r8 * snw_rds(c,j) * 1.e-6_r8) - & 1.0e-10_r8 endif - endif - - ! Compaction occurring during melt - - if (imelt(c,j) == 1) then - if(subgridflag==1 .and. (col_pp%is_soil(c) .or. col_pp%is_crop(c))) then - ! first term is delta mass over mass - ddz3 = max(0._r8,min(1._r8,(swe_old(c,j) - wx)/wx)) - ! 2nd term is delta fsno over fsno, allowing for negative values for ddz3 - if ((swe_old(c,j) - wx) > 0._r8) then - wsum = sum(h2osoi_liq(c,snl(c)+1:0)+h2osoi_ice(c,snl(c)+1:0)) - fsno_melt = 1. - (acos(2.*min(1._r8,wsum/int_snow(c)) - 1._r8)/rpi)**(n_melt(c)) - - ddz3 = ddz3 - max(0._r8,(fsno_melt - frac_sno(c))/frac_sno(c)) - endif - ddz3 = -1._r8/dtime * ddz3 - else - ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) - endif - else - ddz3 = 0._r8 - end if - - if (use_firn_percolation_and_compaction) then - ! Compaction occurring due to wind drift - call WindDriftCompaction( & - bi = bi, & - forc_wind = forc_wind(t), & - dz = dz(c,j), & - zpseudo = zpseudo(c), & - mobile = mobile(c), & - compaction_rate = ddz4) - else - ddz4 = 0.0_r8 - end if - - ! Time rate of fractional change in dz (units of s-1) + ! Compaction occurring during melt + if (imelt(c,j) == 1) then + if(subgridflag==1 .and. (ltype(col_pp%landunit(c)) == istsoil .or. ltype(col_pp%landunit(c)) == istcrop)) then + ! first term is delta mass over mass + ddz3 = max(0._r8,min(1._r8,(swe_old(c,j) - wx)/wx)) + ! 2nd term is delta fsno over fsno, allowing for negative values for ddz3 + if ((swe_old(c,j) - wx) > 0._r8) then + wsum = sum(h2osoi_liq(c,snl(c)+1:0)+h2osoi_ice(c,snl(c)+1:0)) + fsno_melt = 1. - (acos(2.*min(1._r8,wsum/int_snow(c)) - 1._r8)/rpi)**(n_melt(c)) + + ddz3 = ddz3 - max(0._r8,(fsno_melt - frac_sno(c))/frac_sno(c)) + endif + ddz3 = -1._r8/dtime * ddz3 + else + ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + endif + else + ddz3 = 0._r8 + end if + + ! Compaction occurring due to wind drift + call WindDriftCompaction( & + bi = bi, & + forc_wind = forc_wind(t), & + dz = dz(c,j), & + zpseudo = zpseudo(fc), & + mobile = mobile(fc), & + compaction_rate = ddz4) + + ! Time rate of fractional change in dz (units of s-1) pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 @@ -746,24 +771,113 @@ subroutine SnowCompaction(bounds, num_snowc, filter_snowc, & dz(c,j) = max(dz(c,j) * (1._r8+pdzdtc*dtime),(h2osoi_ice(c,j)/denice+ h2osoi_liq(c,j)/denh2o)/frac_sno(c)) - else ! from CLMv5 + else ! from CLMv5 ! 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(c) = .false. - end if + mobile(fc) = .false. + end if - ! Pressure of overlying snow + ! Pressure of overlying snow - burden(c) = burden(c) + wx + burden(fc) = burden(fc) + wx + end if + end do + end do + else - end if - end do - end do + !NOTE: revisit these loops + !$acc parallel loop independent gang vector default(present) private(burden_noextra) + do fc = 1, num_snowc + c = filter_snowc(fc) + burden_noextra = 0._r8 + !$acc loop seq + do j = snl(c)+1, 0 + !if (j >= ) then + wx = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) + void = 1._r8 - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o)& + /(frac_sno(c) * dz(c,j)) + ! If void is negative, then increase dz such that void = 0. + ! This should be done for any landunit, but for now is done only for glacier_mec 1andunits. + + ! I don't think the next 5 lines are necessary (removed in CLMv5) + l = col_pp%landunit(c) + if (ltype(l)==istice_mec .and. void < 0._r8) then + dz(c,j) = h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o + void = 0._r8 + endif + + ! Allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001_r8 .and. h2osoi_ice(c,j) > .1_r8) then + + bi = h2osoi_ice(c,j) / (frac_sno(c) * dz(c,j)) + fi = h2osoi_ice(c,j) / wx + td = tfrz-t_soisno(c,j) + dexpf = exp(-c4*td) + + ! Settling as a result of destructive metamorphism + ddz1 = -c3*dexpf + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3_r8*(bi-dm)) - end associate + ! Liquid water term + + if (h2osoi_liq(c,j) > 0.01_r8*dz(c,j)*frac_sno(c)) ddz1=ddz1*c5 + + ! Compaction due to overburden + ddz2 = -(burden_noextra+wx/2._r8)*exp(-0.08_r8*td - c2*bi)/eta0 + + ! Compaction occurring during melt + + if (imelt(c,j) == 1) then + if(subgridflag==1 .and. (ltype(col_pp%landunit(c)) == istsoil .or. ltype(col_pp%landunit(c)) == istcrop)) then + ! first term is delta mass over mass + ddz3 = max(0._r8,min(1._r8,(swe_old(c,j) - wx)/wx)) + ! 2nd term is delta fsno over fsno, allowing for negative values for ddz3 + if ((swe_old(c,j) - wx) > 0._r8) then + wsum = sum(h2osoi_liq(c,snl(c)+1:0)+h2osoi_ice(c,snl(c)+1:0)) + fsno_melt = 1. - (acos(2.*min(1._r8,wsum/int_snow(c)) - 1._r8)/rpi)**(n_melt(c)) + + ddz3 = ddz3 - max(0._r8,(fsno_melt - frac_sno(c))/frac_sno(c)) + endif + ddz3 = -1._r8/dtime * ddz3 + else + ddz3 = - 1._r8/dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j)) + endif + else + ddz3 = 0._r8 + end if + + ddz4 = 0.0_r8 + + ! Time rate of fractional change in dz (units of s-1) + pdzdtc = ddz1 + ddz2 + ddz3 + ddz4 + + ! The change in dz due to compaction + ! Limit compaction to be no greater than fully saturated layer thickness + + dz(c,j) = max(dz(c,j) * (1._r8+pdzdtc*dtime),(h2osoi_ice(c,j)/denice+ h2osoi_liq(c,j)/denh2o)/frac_sno(c)) + + end if + + ! Pressure of overlying snow + burden_noextra = burden_noextra + wx + !end if + end do !j loop now + end do ! filter loop + end if + + !$acc exit data delete(& + !$acc burden(:), & + !$acc zpseudo(:), & + !$acc mobile(:), & + !$acc ddz1_fresh, & + !$acc ddz1, & + !$acc ddz3, & + !$acc burden_noextra) + + end associate end subroutine SnowCompaction !----------------------------------------------------------------------- @@ -777,7 +891,6 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & ! clm\_combo.f90 then executes the combination of mass and energy. ! ! !USES: - !$acc routine seq use landunit_varcon , only : istsoil, istdlak, istsoil, istwet, istice, istice_mec, istcrop use LakeCon , only : lsadz use elm_varcon , only : denh2o @@ -793,15 +906,16 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & integer :: c, fc ! column indices integer :: i,k ! loop indices integer :: j,l ! node indices - integer :: msn_old(bounds%begc:bounds%endc) ! number of top snow layer - integer :: mssi(bounds%begc:bounds%endc) ! node index + integer :: msn_old(1:num_snowc) ! number of top snow layer + integer :: mssi (1:num_snowc) ! node index integer :: neibor ! adjacent node selected for combination real(r8):: dzminloc_mssi_c ! dzminloc evaluated at mssi(c) - real(r8):: zwice(bounds%begc:bounds%endc) ! total ice mass in snow - real(r8):: zwliq (bounds%begc:bounds%endc) ! total liquid water in snow + real(r8):: zwice (1:num_snowc) ! total ice mass in snow + real(r8):: zwliq (1:num_snowc) ! total liquid water in snow real(r8):: dzmin(5) ! minimum of top snow layer real(r8):: dzminloc(5) ! minimum of top snow layer (local) real(r8):: dzminloc16(16) ! minimum of top snow layer (local) + real(r8) :: sum1, sum2, sum3, sum4 data dzmin /0.010_r8, 0.015_r8, 0.025_r8, 0.055_r8, 0.115_r8/ @@ -830,7 +944,7 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & h2osoi_ice => col_ws%h2osoi_ice , & ! Output: [real(r8) (:,:) ] ice lens (kg/m2) h2osoi_liq => col_ws%h2osoi_liq , & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective snow grain radius (col,lyr) [microns, m^-6] - mflx_snowlyr_col => col_wf%mflx_snowlyr , & ! Output: [real(r8) (:) ] mass flux to top soil layer due to disappearance of snow (kg H2O /s) + mflx_snowlyr_col => col_wf%mflx_snowlyr , & ! Output: [real(r8) (:) ] mass flux to top soil layer due to disappearance of snow (kg H2O /s) qflx_sl_top_soil => col_wf%qflx_sl_top_soil , & ! Output: [real(r8) (:) ] liquid water + ice from layer above soil to top soil layer or sent to qflx_qrgwl (mm H2O/s) qflx_snow2topsoi => col_wf%qflx_snow2topsoi , & ! Output: [real(r8) (:) ] liquid water merged into top soil from snow @@ -840,10 +954,19 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & zi => col_pp%zi , & ! Output: [real(r8) (:,:) ] interface level below a "z" level (m) z => col_pp%z & ! Output: [real(r8) (:,:) ] layer thickness (m) ) - + !$acc enter data create(& + !$acc msn_old(:) , & + !$acc mssi(:) , & + !$acc zwice(:) , & + !$acc zwliq(:) , & + !$acc dzmin(:) , & + !$acc dzminloc(:), & + !$acc dzminloc16(:), & + !$acc sum1, sum2, sum3, sum4) ! Check the mass of ice lens of snow, when the total is less than a small value, ! combine it with the underlying neighbor. + ! dzmin will stay constant between timesteps if (.not. use_extrasnowlayers) then @@ -867,21 +990,23 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & end if end if + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) - msn_old(c) = snl(c) + msn_old(fc) = snl(c) qflx_sl_top_soil(c) = 0._r8 qflx_snow2topsoi(c) = 0._r8 mflx_snowlyr_col(c) = 0._r8 end do ! The following loop is NOT VECTORIZED - + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) l = col_pp%landunit(c) - do j = msn_old(c)+1,0 + !$acc loop seq + do j = msn_old(fc)+1,0 ! use 0.01 to avoid runaway ice buildup if (h2osoi_ice(c,j) <= .01_r8) then if (col_pp%is_soil(c) .or. urbpoi(l) .or. col_pp%is_crop(c)) then @@ -930,6 +1055,7 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & ! shift all elements above this down one. if (j > snl(c)+1 .and. snl(c) < -1) then + !$acc loop seq do i = j, snl(c)+2, -1 ! If the layer closest to the surface is less than 0.1 mm and the ltype is not ! urban, soil or crop, the h2osoi_liq and h2osoi_ice associated with this layer is sent @@ -960,29 +1086,30 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & end do end do + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3,sum4) do fc = 1, num_snowc - c = filter_snowc(fc) - h2osno(c) = 0._r8 - snow_depth(c) = 0._r8 - zwice(c) = 0._r8 - zwliq(c) = 0._r8 - end do - - do j = -nlevsno+1,0 - do fc = 1, num_snowc - c = filter_snowc(fc) + c = filter_snowc(fc) + sum1 = 0._r8; sum2 = 0._r8; + sum3 = 0._r8; sum4 = 0._r8; + !$acc loop vector reduction(+:sum1,sum2,sum3,sum4) + do j = -nlevsno+1,0 if (j >= snl(c)+1) then - h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j) - snow_depth(c) = snow_depth(c) + dz(c,j) - zwice(c) = zwice(c) + h2osoi_ice(c,j) - zwliq(c) = zwliq(c) + h2osoi_liq(c,j) + sum1 = sum1 + h2osoi_ice(c,j) + h2osoi_liq(c,j) + sum2 = sum2 + dz(c,j) + sum3 = sum3 + h2osoi_ice(c,j) + sum4 = sum4 + h2osoi_liq(c,j) end if - end do + end do + h2osno(c) = sum1 + snow_depth(c) = sum2 + zwice(fc) = sum3 + zwliq(fc) = sum4 end do ! Check the snow depth - all snow gone ! The liquid water assumes ponding on soil surface. + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) l = col_pp%landunit(c) @@ -992,7 +1119,7 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & .or. (h2osno(c)/(frac_sno_eff(c)*snow_depth(c)) < 50._r8)))) then snl(c) = 0 - h2osno(c) = zwice(c) + h2osno(c) = zwice(fc) mss_bcphi(c,:) = 0._r8 mss_bcpho(c,:) = 0._r8 @@ -1007,9 +1134,9 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & ! this is where water is transfered from layer 0 (snow) to layer 1 (soil) if (col_pp%is_soil(c) .or. urbpoi(l) .or. col_pp%is_crop(c)) then h2osoi_liq(c,0) = 0.0_r8 - h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c) - qflx_snow2topsoi(c) = zwliq(c)/dtime - mflx_snowlyr_col(c) = mflx_snowlyr_col(c) + zwliq(c)/dtime + h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(fc) + qflx_snow2topsoi(c) = zwliq(fc)/dtime + mflx_snowlyr_col(c) = mflx_snowlyr_col(c) + zwliq(fc)/dtime end if if (ltype(l) == istwet) then h2osoi_liq(c,0) = 0.0_r8 @@ -1037,14 +1164,14 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & if (snl(c) < -1) then - msn_old(c) = snl(c) - mssi(c) = 1 + msn_old(fc) = snl(c) + mssi(fc) = 1 - do i = msn_old(c)+1,0 + do i = msn_old(fc)+1,0 if (.not. use_extrasnowlayers) then - dzminloc_mssi_c = dzminloc(mssi(c)) + dzminloc_mssi_c = dzminloc(mssi(fc)) else - dzminloc_mssi_c = dzminloc16(mssi(c)) + dzminloc_mssi_c = dzminloc16(mssi(fc)) end if if ((frac_sno_eff(c)*dz(c,i) < dzminloc_mssi_c) .or. & ((h2osoi_ice(c,i) + h2osoi_liq(c,i))/(frac_sno_eff(c)*dz(c,i)) < 50._r8)) then @@ -1118,7 +1245,7 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & else ! The layer thickness is greater than the prescribed minimum value - mssi(c) = mssi(c) + 1 + mssi(fc) = mssi(fc) + 1 end if end do @@ -1128,18 +1255,48 @@ subroutine CombineSnowLayers(bounds, num_snowc, filter_snowc, & end do ! Reset the node depth and the depth of layer interface + !NOTE: racecondition? Testing out two loop structure: + !$acc parallel default(present) + !$acc loop independent gang vector + do fc = 1, num_snowc + c = filter_snowc(fc) + !NOTE: can replace the loop bounds with [0,snl(c)+1] here now? + !$acc loop seq + do j = 0, -nlevsno+1, -1 + if(j >= snl(c) + 1) then + zi(c,j-1) = zi(c,j) - dz(c,j) + end if + end do + end do + + !$acc loop independent gang vector collapse(2) + do j = 0, -nlevsno+1, -1 + do fc = 1, num_snowc + c = filter_snowc(fc) + if (j >= snl(c) + 1) then + z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) + end if + end do + end do + !$acc end parallel + - do j = 0, -nlevsno+1, -1 - do fc = 1, num_snowc - c = filter_snowc(fc) - if (j >= snl(c) + 1) then - z(c,j) = zi(c,j) - 0.5_r8*dz(c,j) - zi(c,j-1) = zi(c,j) - dz(c,j) - end if - end do - end do + + !$acc exit data delete(& + !$acc msn_old(:), & + !$acc mssi(:), & + !$acc zwice(:), & + !$acc zwliq(:), & + !$acc dzmin(:), & + !$acc dzminloc(:), & + !$acc dzminloc16(:), & + !$acc sum1, & + !$acc sum2, & + !$acc sum3, & + !$acc sum4) end associate + end subroutine CombineSnowLayers !----------------------------------------------------------------------- @@ -1150,7 +1307,6 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & ! Subdivides snow layers if they exceed their prescribed maximum thickness. ! ! !USES: - !$acc routine seq use elm_varcon, only : tfrz use LakeCon , only : lsadz ! @@ -1162,40 +1318,42 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & logical , intent(in) :: is_lake !TODO - this should be examined and removed in the future ! ! !LOCAL VARIABLES: - integer :: j, c, fc, k ! indices - real(r8) :: drr ! thickness of the combined [m] - integer :: msno ! number of snow layer 1 (top) to msno (bottom) - real(r8) :: dzsno(bounds%begc:bounds%endc,nlevsno) ! Snow layer thickness [m] - real(r8) :: swice(bounds%begc:bounds%endc,nlevsno) ! Partial volume of ice [m3/m3] - real(r8) :: swliq(bounds%begc:bounds%endc,nlevsno) ! Partial volume of liquid water [m3/m3] - real(r8) :: tsno(bounds%begc:bounds%endc ,nlevsno) ! Nodel temperature [K] - real(r8) :: zwice ! temporary - real(r8) :: zwliq ! temporary - real(r8) :: propor ! temporary - real(r8) :: dtdz ! temporary + integer :: j, c, fc, k ! indices + real(r8) :: drr ! thickness of the combined [m] + integer :: msno ! number of snow layer 1 (top) to msno (bottom) + real(r8) :: dzsno(1:num_snowc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(1:num_snowc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(1:num_snowc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(1:num_snowc ,nlevsno) ! Nodel temperature [K] + real(r8) :: zwice ! temporary + real(r8) :: zwliq ! temporary + real(r8) :: propor ! temporary + real(r8) :: dtdz ! temporary ! temporary variables mimicking the structure of other layer division variables - real(r8) :: mbc_phi(bounds%begc:bounds%endc,nlevsno) ! mass of BC in each snow layer - real(r8) :: zmbc_phi ! temporary - real(r8) :: mbc_pho(bounds%begc:bounds%endc,nlevsno) ! mass of BC in each snow layer - real(r8) :: zmbc_pho ! temporary - real(r8) :: moc_phi(bounds%begc:bounds%endc,nlevsno) ! mass of OC in each snow layer - real(r8) :: zmoc_phi ! temporary - real(r8) :: moc_pho(bounds%begc:bounds%endc,nlevsno) ! mass of OC in each snow layer - real(r8) :: zmoc_pho ! temporary - real(r8) :: mdst1(bounds%begc:bounds%endc,nlevsno) ! mass of dust 1 in each snow layer - real(r8) :: zmdst1 ! temporary - real(r8) :: mdst2(bounds%begc:bounds%endc,nlevsno) ! mass of dust 2 in each snow layer - real(r8) :: zmdst2 ! temporary - real(r8) :: mdst3(bounds%begc:bounds%endc,nlevsno) ! mass of dust 3 in each snow layer - real(r8) :: zmdst3 ! temporary - real(r8) :: mdst4(bounds%begc:bounds%endc,nlevsno) ! mass of dust 4 in each snow layer - real(r8) :: zmdst4 ! temporary - real(r8) :: rds(bounds%begc:bounds%endc,nlevsno) + real(r8) :: mbc_phi(1:num_snowc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_phi ! temporary + real(r8) :: mbc_pho(1:num_snowc,nlevsno) ! mass of BC in each snow layer + real(r8) :: zmbc_pho ! temporary + real(r8) :: moc_phi(1:num_snowc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_phi ! temporary + real(r8) :: moc_pho(1:num_snowc,nlevsno) ! mass of OC in each snow layer + real(r8) :: zmoc_pho ! temporary + real(r8) :: mdst1(1:num_snowc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: zmdst1 ! temporary + real(r8) :: mdst2(1:num_snowc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: zmdst2 ! temporary + real(r8) :: mdst3(1:num_snowc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: zmdst3 ! temporary + real(r8) :: mdst4(1:num_snowc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: zmdst4 ! temporary + real(r8) :: rds(1:num_snowc,nlevsno) ! Variables for consistency check - real(r8) :: dztot(bounds%begc:bounds%endc) - real(r8) :: snwicetot(bounds%begc:bounds%endc) - real(r8) :: snwliqtot(bounds%begc:bounds%endc) + real(r8) :: dztot(1:num_snowc) + real(r8) :: snwicetot(1:num_snowc) + real(r8) :: snwliqtot(1:num_snowc) real(r8) :: offset ! temporary + real(r8) :: sum1, sum2, sum3 + integer :: snl_idx !----------------------------------------------------------------------- associate( & @@ -1206,71 +1364,96 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & frac_sno => col_ws%frac_sno_eff , & ! Output: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) snw_rds => col_ws%snw_rds , & ! Output: [real(r8) (:,:) ] effective snow grain radius (col,lyr) [microns, m^-6] - mss_bcphi => aerosol_vars%mss_bcphi_col , & ! Output: [real(r8) (:,:) ] hydrophilic BC mass in snow (col,lyr) [kg] - mss_bcpho => aerosol_vars%mss_bcpho_col , & ! Output: [real(r8) (:,:) ] hydrophobic BC mass in snow (col,lyr) [kg] - mss_ocphi => aerosol_vars%mss_ocphi_col , & ! Output: [real(r8) (:,:) ] hydrophilic OC mass in snow (col,lyr) [kg] - mss_ocpho => aerosol_vars%mss_ocpho_col , & ! Output: [real(r8) (:,:) ] hydrophobic OC mass in snow (col,lyr) [kg] - mss_dst1 => aerosol_vars%mss_dst1_col , & ! Output: [real(r8) (:,:) ] dust species 1 mass in snow (col,lyr) [kg] - mss_dst2 => aerosol_vars%mss_dst2_col , & ! Output: [real(r8) (:,:) ] dust species 2 mass in snow (col,lyr) [kg] - mss_dst3 => aerosol_vars%mss_dst3_col , & ! Output: [real(r8) (:,:) ] dust species 3 mass in snow (col,lyr) [kg] - mss_dst4 => aerosol_vars%mss_dst4_col , & ! Output: [real(r8) (:,:) ] dust species 4 mass in snow (col,lyr) [kg] - - snl => col_pp%snl , & ! Output: [integer (:) ] number of snow layers - dz => col_pp%dz , & ! Output: [real(r8) (:,:) ] layer depth (m) - zi => col_pp%zi , & ! Output: [real(r8) (:,:) ] interface level below a "z" level (m) - z => col_pp%z & ! Output: [real(r8) (:,:) ] layer thickness (m) + mss_bcphi => aerosol_vars%mss_bcphi_col , & ! Output: [real(r8) (:,:) ] hydrophilic BC mass in snow (col,lyr) [kg] + mss_bcpho => aerosol_vars%mss_bcpho_col , & ! Output: [real(r8) (:,:) ] hydrophobic BC mass in snow (col,lyr) [kg] + mss_ocphi => aerosol_vars%mss_ocphi_col , & ! Output: [real(r8) (:,:) ] hydrophilic OC mass in snow (col,lyr) [kg] + mss_ocpho => aerosol_vars%mss_ocpho_col , & ! Output: [real(r8) (:,:) ] hydrophobic OC mass in snow (col,lyr) [kg] + mss_dst1 => aerosol_vars%mss_dst1_col , & ! Output: [real(r8) (:,:) ] dust species 1 mass in snow (col,lyr) [kg] + mss_dst2 => aerosol_vars%mss_dst2_col , & ! Output: [real(r8) (:,:) ] dust species 2 mass in snow (col,lyr) [kg] + mss_dst3 => aerosol_vars%mss_dst3_col , & ! Output: [real(r8) (:,:) ] dust species 3 mass in snow (col,lyr) [kg] + mss_dst4 => aerosol_vars%mss_dst4_col , & ! Output: [real(r8) (:,:) ] dust species 4 mass in snow (col,lyr) [kg] + + snl => col_pp%snl , & ! Output: [integer (:) ] number of snow layers + dz => col_pp%dz , & ! Output: [real(r8) (:,:) ] layer depth (m) + zi => col_pp%zi , & ! Output: [real(r8) (:,:) ] interface level below a "z" level (m) + z => col_pp%z & ! Output: [real(r8) (:,:) ] layer thickness (m) ) + !$acc enter data create(& + !$acc dzsno(:,:), & + !$acc swice(:,:), & + !$acc swliq(:,:), & + !$acc tsno(:,:), & + !$acc mbc_phi(:,:), & + !$acc mbc_pho(:,:), & + !$acc moc_phi(:,:), & + !$acc moc_pho(:,:), & + !$acc mdst1(:,:), & + !$acc mdst2(:,:), & + !$acc mdst3(:,:), & + !$acc mdst4(:,:), & + !$acc rds(:,:), & + !$acc dztot(:), & + !$acc snwicetot(:), & + !$acc snwliqtot(:), & + !$acc sum1, & + !$acc sum2, & + !$acc sum3) if ( is_lake ) then ! Initialize for consistency check - do j = -nlevsno+1,0 - do fc = 1, num_snowc - c = filter_snowc(fc) - - if (j == -nlevsno+1) then - dztot(c) = 0._r8 - snwicetot(c) = 0._r8 - snwliqtot(c) = 0._r8 - end if - + !$acc parallel loop independent gang vector default(present) private(sum1,sum2,sum3) + do fc = 1, num_snowc + c = filter_snowc(fc) + sum1 = 0._r8; sum2 = 0._r8; sum3 =0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do j = -nlevsno+1,0 if (j >= snl(c)+1) then - dztot(c) = dztot(c) + dz(c,j) - snwicetot(c) = snwicetot(c) + h2osoi_ice(c,j) - snwliqtot(c) = snwliqtot(c) + h2osoi_liq(c,j) + sum1 = sum1 + dz(c,j) + sum2 = sum2 + h2osoi_ice(c,j) + sum3 = sum3 + h2osoi_liq(c,j) end if end do + dztot(fc) = sum1 + snwicetot(fc) = sum2 + snwliqtot(fc) = sum3 end do end if ! Begin calculation - note that the following column loops are only invoked ! for snow-covered columns + !$acc parallel loop independent gang vector default(present) collapse(2) + !!!$acc present(mss_bcphi(:,:),mss_bcpho(:,:),mss_ocphi(:,:),mss_ocpho(:,:) & + !!!$acc ,mss_dst1(:,:),mss_dst2(:,:),mss_dst3(:,:),mss_dst4(:,:) ,snw_rds(:,:), & + !!!$acc h2osoi_ice(:,:),h2osoi_liq(:,:), t_soisno(:,:),dz(:,:),snl(:)) do j = 1,nlevsno do fc = 1, num_snowc c = filter_snowc(fc) + snl_idx = j+snl(c) if (j <= abs(snl(c))) then if (is_lake) then - dzsno(c,j) = dz(c,j+snl(c)) + dzsno(fc,j) = dz(c,snl_idx) else - dzsno(c,j) = frac_sno(c)*dz(c,j+snl(c)) + dzsno(fc,j) = frac_sno(c)*dz(c,snl_idx) end if - swice(c,j) = h2osoi_ice(c,j+snl(c)) - swliq(c,j) = h2osoi_liq(c,j+snl(c)) - tsno(c,j) = t_soisno(c,j+snl(c)) - - mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) - mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) - moc_phi(c,j) = mss_ocphi(c,j+snl(c)) - moc_pho(c,j) = mss_ocpho(c,j+snl(c)) - mdst1(c,j) = mss_dst1(c,j+snl(c)) - mdst2(c,j) = mss_dst2(c,j+snl(c)) - mdst3(c,j) = mss_dst3(c,j+snl(c)) - mdst4(c,j) = mss_dst4(c,j+snl(c)) - rds(c,j) = snw_rds(c,j+snl(c)) + swice(fc,j) = h2osoi_ice(c,snl_idx) + swliq(fc,j) = h2osoi_liq(c,snl_idx) + tsno (fc,j) = t_soisno(c,snl_idx) + + mbc_phi(fc,j) = mss_bcphi(c,snl_idx) + mbc_pho(fc,j) = mss_bcpho(c,snl_idx) + moc_phi(fc,j) = mss_ocphi(c,snl_idx) + moc_pho(fc,j) = mss_ocpho(c,snl_idx) + mdst1(fc,j) = mss_dst1(c,snl_idx) + mdst2(fc,j) = mss_dst2(c,snl_idx) + mdst3(fc,j) = mss_dst3(c,snl_idx) + mdst4(fc,j) = mss_dst4(c,snl_idx) + rds(fc,j) = snw_rds(c,snl_idx) end if end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_snowc c = filter_snowc(fc) @@ -1283,33 +1466,33 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (dzsno(c,1) > 0.03_r8 + offset) then + if (dzsno(fc,1) > 0.03_r8 + offset) then msno = 2 - dzsno(c,1) = dzsno(c,1)/2._r8 - swice(c,1) = swice(c,1)/2._r8 - swliq(c,1) = swliq(c,1)/2._r8 - dzsno(c,2) = dzsno(c,1) - swice(c,2) = swice(c,1) - swliq(c,2) = swliq(c,1) - tsno(c,2) = tsno(c,1) - - mbc_phi(c,1) = mbc_phi(c,1)/2._r8 - mbc_phi(c,2) = mbc_phi(c,1) - mbc_pho(c,1) = mbc_pho(c,1)/2._r8 - mbc_pho(c,2) = mbc_pho(c,1) - moc_phi(c,1) = moc_phi(c,1)/2._r8 - moc_phi(c,2) = moc_phi(c,1) - moc_pho(c,1) = moc_pho(c,1)/2._r8 - moc_pho(c,2) = moc_pho(c,1) - mdst1(c,1) = mdst1(c,1)/2._r8 - mdst1(c,2) = mdst1(c,1) - mdst2(c,1) = mdst2(c,1)/2._r8 - mdst2(c,2) = mdst2(c,1) - mdst3(c,1) = mdst3(c,1)/2._r8 - mdst3(c,2) = mdst3(c,1) - mdst4(c,1) = mdst4(c,1)/2._r8 - mdst4(c,2) = mdst4(c,1) - rds(c,2) = rds(c,1) + dzsno(fc,1) = dzsno(fc,1)/2._r8 + swice(fc,1) = swice(fc,1)/2._r8 + swliq(fc,1) = swliq(fc,1)/2._r8 + dzsno(fc,2) = dzsno(fc,1) + swice(fc,2) = swice(fc,1) + swliq(fc,2) = swliq(fc,1) + tsno(fc,2) = tsno(fc,1) + + mbc_phi(fc,1) = mbc_phi(fc,1)/2._r8 + mbc_phi(fc,2) = mbc_phi(fc,1) + mbc_pho(fc,1) = mbc_pho(fc,1)/2._r8 + mbc_pho(fc,2) = mbc_pho(fc,1) + moc_phi(fc,1) = moc_phi(fc,1)/2._r8 + moc_phi(fc,2) = moc_phi(fc,1) + moc_pho(fc,1) = moc_pho(fc,1)/2._r8 + moc_pho(fc,2) = moc_pho(fc,1) + mdst1(fc,1) = mdst1(fc,1)/2._r8 + mdst1(fc,2) = mdst1(fc,1) + mdst2(fc,1) = mdst2(fc,1)/2._r8 + mdst2(fc,2) = mdst2(fc,1) + mdst3(fc,1) = mdst3(fc,1)/2._r8 + mdst3(fc,2) = mdst3(fc,1) + mdst4(fc,1) = mdst4(fc,1)/2._r8 + mdst4(fc,2) = mdst4(fc,1) + rds(fc,2) = rds(fc,1) end if end if @@ -1320,72 +1503,74 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (dzsno(c,1) > 0.02_r8 + offset) then + if (dzsno(fc,1) > 0.02_r8 + offset) then if (is_lake) then - drr = dzsno(c,1) - 0.02_r8 - lsadz + drr = dzsno(fc,1) - 0.02_r8 - lsadz else - drr = dzsno(c,1) - 0.02_r8 + drr = dzsno(fc,1) - 0.02_r8 end if - propor = drr/dzsno(c,1) - zwice = propor*swice(c,1) - zwliq = propor*swliq(c,1) - - zmbc_phi = propor*mbc_phi(c,1) - zmbc_pho = propor*mbc_pho(c,1) - zmoc_phi = propor*moc_phi(c,1) - zmoc_pho = propor*moc_pho(c,1) - zmdst1 = propor*mdst1(c,1) - zmdst2 = propor*mdst2(c,1) - zmdst3 = propor*mdst3(c,1) - zmdst4 = propor*mdst4(c,1) + propor = drr/dzsno(fc,1) + zwice = propor*swice(fc,1) + zwliq = propor*swliq(fc,1) + + zmbc_phi = propor*mbc_phi(fc,1) + zmbc_pho = propor*mbc_pho(fc,1) + zmoc_phi = propor*moc_phi(fc,1) + zmoc_pho = propor*moc_pho(fc,1) + zmdst1 = propor*mdst1(fc,1) + zmdst2 = propor*mdst2(fc,1) + zmdst3 = propor*mdst3(fc,1) + zmdst4 = propor*mdst4(fc,1) if (is_lake) then - propor = (0.02_r8+lsadz)/dzsno(c,1) + propor = (0.02_r8+lsadz)/dzsno(fc,1) else - propor = 0.02_r8/dzsno(c,1) + propor = 0.02_r8/dzsno(fc,1) endif - swice(c,1) = propor*swice(c,1) - swliq(c,1) = propor*swliq(c,1) + swice(fc,1) = propor*swice(fc,1) + swliq(fc,1) = propor*swliq(fc,1) - mbc_phi(c,1) = propor*mbc_phi(c,1) - mbc_pho(c,1) = propor*mbc_pho(c,1) - moc_phi(c,1) = propor*moc_phi(c,1) - moc_pho(c,1) = propor*moc_pho(c,1) - mdst1(c,1) = propor*mdst1(c,1) - mdst2(c,1) = propor*mdst2(c,1) - mdst3(c,1) = propor*mdst3(c,1) - mdst4(c,1) = propor*mdst4(c,1) + mbc_phi(fc,1) = propor*mbc_phi(fc,1) + mbc_pho(fc,1) = propor*mbc_pho(fc,1) + moc_phi(fc,1) = propor*moc_phi(fc,1) + moc_pho(fc,1) = propor*moc_pho(fc,1) + mdst1(fc,1) = propor*mdst1(fc,1) + mdst2(fc,1) = propor*mdst2(fc,1) + mdst3(fc,1) = propor*mdst3(fc,1) + mdst4(fc,1) = propor*mdst4(fc,1) if (is_lake) then - dzsno(c,1) = 0.02_r8 + lsadz + dzsno(fc,1) = 0.02_r8 + lsadz else - dzsno(c,1) = 0.02_r8 + dzsno(fc,1) = 0.02_r8 end if - mbc_phi(c,2) = mbc_phi(c,2)+zmbc_phi ! (combo) - mbc_pho(c,2) = mbc_pho(c,2)+zmbc_pho ! (combo) - moc_phi(c,2) = moc_phi(c,2)+zmoc_phi ! (combo) - moc_pho(c,2) = moc_pho(c,2)+zmoc_pho ! (combo) - mdst1(c,2) = mdst1(c,2)+zmdst1 ! (combo) - mdst2(c,2) = mdst2(c,2)+zmdst2 ! (combo) - mdst3(c,2) = mdst3(c,2)+zmdst3 ! (combo) - mdst4(c,2) = mdst4(c,2)+zmdst4 ! (combo) + mbc_phi(fc,2) = mbc_phi(fc,2)+zmbc_phi ! (combo) + mbc_pho(fc,2) = mbc_pho(fc,2)+zmbc_pho ! (combo) + moc_phi(fc,2) = moc_phi(fc,2)+zmoc_phi ! (combo) + moc_pho(fc,2) = moc_pho(fc,2)+zmoc_pho ! (combo) + mdst1(fc,2) = mdst1(fc,2)+zmdst1 ! (combo) + mdst2(fc,2) = mdst2(fc,2)+zmdst2 ! (combo) + mdst3(fc,2) = mdst3(fc,2)+zmdst3 ! (combo) + mdst4(fc,2) = mdst4(fc,2)+zmdst4 ! (combo) #ifdef MODAL_AER !mgf++ bugfix - rds(c,2) = (rds(c,2)*(swliq(c,2)+swice(c,2)) + rds(c,1)*(zwliq+zwice))/(swliq(c,2)+swice(c,2)+zwliq+zwice) - if ((rds(c,2) < 30.) .or. (rds(c,2) > 1500.)) then - write (iulog,*) "2. SNICAR ERROR: snow grain radius of",rds(c,2),rds(c,1) - write (iulog,*) "swliq, swice, zwliq, zwice", swliq(c,2), swice(c,2),zwliq, zwice + rds(fc,2) = (rds(fc,2)*(swliq(fc,2)+swice(fc,2)) + rds(fc,1)*(zwliq+zwice))/(swliq(fc,2)+swice(fc,2)+zwliq+zwice) + if ((rds(fc,2) < 30.) .or. (rds(fc,2) > 1500.)) then + write (iulog,*) "2. SNICAR ERROR: snow grain radius of",rds(fc,2),rds(fc,1) + write (iulog,*) "swliq, swice, zwliq, zwice", swliq(fc,2), swice(fc,2),zwliq, zwice + write (iulog,*) "propor: ", propor + write (iulog,*) "dzsno : ", dzsno(fc,1) write (iulog,*) "layers ", msno endif !mgf-- #else - rds(c,2) = rds(c,1) ! (combo) + rds(fc,2) = rds(fc,1) ! (combo) #endif - call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, & - zwliq, zwice, tsno(c,1)) + call Combo (dzsno(fc,2), swliq(fc,2), swice(fc,2), tsno(fc,2), drr, & + zwliq, zwice, tsno(fc,1)) ! Subdivide a new layer if (is_lake) then @@ -1393,39 +1578,39 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (msno <= 2 .and. dzsno(c,2) > 0.07_r8 + offset) then + if (msno <= 2 .and. dzsno(fc,2) > 0.07_r8 + offset) then msno = 3 - dtdz = (tsno(c,1) - tsno(c,2))/((dzsno(c,1)+dzsno(c,2))/2._r8) - dzsno(c,2) = dzsno(c,2)/2._r8 - swice(c,2) = swice(c,2)/2._r8 - swliq(c,2) = swliq(c,2)/2._r8 - dzsno(c,3) = dzsno(c,2) - swice(c,3) = swice(c,2) - swliq(c,3) = swliq(c,2) - tsno(c,3) = tsno(c,2) - dtdz*dzsno(c,2)/2._r8 - if (tsno(c,3) >= tfrz) then - tsno(c,3) = tsno(c,2) + dtdz = (tsno(fc,1) - tsno(fc,2))/((dzsno(fc,1)+dzsno(fc,2))/2._r8) + dzsno(fc,2) = dzsno(fc,2)/2._r8 + swice(fc,2) = swice(fc,2)/2._r8 + swliq(fc,2) = swliq(fc,2)/2._r8 + dzsno(fc,3) = dzsno(fc,2) + swice(fc,3) = swice(fc,2) + swliq(fc,3) = swliq(fc,2) + tsno(fc,3) = tsno(fc,2) - dtdz*dzsno(fc,2)/2._r8 + if (tsno(fc,3) >= tfrz) then + tsno(fc,3) = tsno(fc,2) else - tsno(c,2) = tsno(c,2) + dtdz*dzsno(c,2)/2._r8 + tsno(fc,2) = tsno(fc,2) + dtdz*dzsno(fc,2)/2._r8 endif - mbc_phi(c,2) = mbc_phi(c,2)/2._r8 - mbc_phi(c,3) = mbc_phi(c,2) - mbc_pho(c,2) = mbc_pho(c,2)/2._r8 - mbc_pho(c,3) = mbc_pho(c,2) - moc_phi(c,2) = moc_phi(c,2)/2._r8 - moc_phi(c,3) = moc_phi(c,2) - moc_pho(c,2) = moc_pho(c,2)/2._r8 - moc_pho(c,3) = moc_pho(c,2) - mdst1(c,2) = mdst1(c,2)/2._r8 - mdst1(c,3) = mdst1(c,2) - mdst2(c,2) = mdst2(c,2)/2._r8 - mdst2(c,3) = mdst2(c,2) - mdst3(c,2) = mdst3(c,2)/2._r8 - mdst3(c,3) = mdst3(c,2) - mdst4(c,2) = mdst4(c,2)/2._r8 - mdst4(c,3) = mdst4(c,2) - rds(c,3) = rds(c,2) + mbc_phi(fc,2) = mbc_phi(fc,2)/2._r8 + mbc_phi(fc,3) = mbc_phi(fc,2) + mbc_pho(fc,2) = mbc_pho(fc,2)/2._r8 + mbc_pho(fc,3) = mbc_pho(fc,2) + moc_phi(fc,2) = moc_phi(fc,2)/2._r8 + moc_phi(fc,3) = moc_phi(fc,2) + moc_pho(fc,2) = moc_pho(fc,2)/2._r8 + moc_pho(fc,3) = moc_pho(fc,2) + mdst1(fc,2) = mdst1(fc,2)/2._r8 + mdst1(fc,3) = mdst1(fc,2) + mdst2(fc,2) = mdst2(fc,2)/2._r8 + mdst2(fc,3) = mdst2(fc,2) + mdst3(fc,2) = mdst3(fc,2)/2._r8 + mdst3(fc,3) = mdst3(fc,2) + mdst4(fc,2) = mdst4(fc,2)/2._r8 + mdst4(fc,3) = mdst4(fc,2) + rds(fc,3) = rds(fc,2) end if end if @@ -1437,73 +1622,73 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (dzsno(c,2) > 0.05_r8+offset) then + if (dzsno(fc,2) > 0.05_r8+offset) then if (is_lake) then - drr = dzsno(c,2) - 0.05_r8 - lsadz + drr = dzsno(fc,2) - 0.05_r8 - lsadz else - drr = dzsno(c,2) - 0.05_r8 + drr = dzsno(fc,2) - 0.05_r8 end if - propor = drr/dzsno(c,2) - zwice = propor*swice(c,2) - zwliq = propor*swliq(c,2) - - zmbc_phi = propor*mbc_phi(c,2) - zmbc_pho = propor*mbc_pho(c,2) - zmoc_phi = propor*moc_phi(c,2) - zmoc_pho = propor*moc_pho(c,2) - zmdst1 = propor*mdst1(c,2) - zmdst2 = propor*mdst2(c,2) - zmdst3 = propor*mdst3(c,2) - zmdst4 = propor*mdst4(c,2) + propor = drr/dzsno(fc,2) + zwice = propor*swice(fc,2) + zwliq = propor*swliq(fc,2) + + zmbc_phi = propor*mbc_phi(fc,2) + zmbc_pho = propor*mbc_pho(fc,2) + zmoc_phi = propor*moc_phi(fc,2) + zmoc_pho = propor*moc_pho(fc,2) + zmdst1 = propor*mdst1(fc,2) + zmdst2 = propor*mdst2(fc,2) + zmdst3 = propor*mdst3(fc,2) + zmdst4 = propor*mdst4(fc,2) if (is_lake) then - propor = (0.05_r8+lsadz)/dzsno(c,2) + propor = (0.05_r8+lsadz)/dzsno(fc,2) else - propor = 0.05_r8/dzsno(c,2) + propor = 0.05_r8/dzsno(fc,2) end if - swice(c,2) = propor*swice(c,2) - swliq(c,2) = propor*swliq(c,2) - - mbc_phi(c,2) = propor*mbc_phi(c,2) - mbc_pho(c,2) = propor*mbc_pho(c,2) - moc_phi(c,2) = propor*moc_phi(c,2) - moc_pho(c,2) = propor*moc_pho(c,2) - mdst1(c,2) = propor*mdst1(c,2) - mdst2(c,2) = propor*mdst2(c,2) - mdst3(c,2) = propor*mdst3(c,2) - mdst4(c,2) = propor*mdst4(c,2) + swice(fc,2) = propor*swice(fc,2) + swliq(fc,2) = propor*swliq(fc,2) + + mbc_phi(fc,2) = propor*mbc_phi(fc,2) + mbc_pho(fc,2) = propor*mbc_pho(fc,2) + moc_phi(fc,2) = propor*moc_phi(fc,2) + moc_pho(fc,2) = propor*moc_pho(fc,2) + mdst1(fc,2) = propor*mdst1(fc,2) + mdst2(fc,2) = propor*mdst2(fc,2) + mdst3(fc,2) = propor*mdst3(fc,2) + mdst4(fc,2) = propor*mdst4(fc,2) if (is_lake) then - dzsno(c,2) = 0.05_r8+lsadz + dzsno(fc,2) = 0.05_r8+lsadz else - dzsno(c,2) = 0.05_r8 + dzsno(fc,2) = 0.05_r8 end if - mbc_phi(c,3) = mbc_phi(c,3)+zmbc_phi ! (combo) - mbc_pho(c,3) = mbc_pho(c,3)+zmbc_pho ! (combo) - moc_phi(c,3) = moc_phi(c,3)+zmoc_phi ! (combo) - moc_pho(c,3) = moc_pho(c,3)+zmoc_pho ! (combo) - mdst1(c,3) = mdst1(c,3)+zmdst1 ! (combo) - mdst2(c,3) = mdst2(c,3)+zmdst2 ! (combo) - mdst3(c,3) = mdst3(c,3)+zmdst3 ! (combo) - mdst4(c,3) = mdst4(c,3)+zmdst4 ! (combo) + mbc_phi(fc,3) = mbc_phi(fc,3)+zmbc_phi ! (combo) + mbc_pho(fc,3) = mbc_pho(fc,3)+zmbc_pho ! (combo) + moc_phi(fc,3) = moc_phi(fc,3)+zmoc_phi ! (combo) + moc_pho(fc,3) = moc_pho(fc,3)+zmoc_pho ! (combo) + mdst1(fc,3) = mdst1(fc,3)+zmdst1 ! (combo) + mdst2(fc,3) = mdst2(fc,3)+zmdst2 ! (combo) + mdst3(fc,3) = mdst3(fc,3)+zmdst3 ! (combo) + mdst4(fc,3) = mdst4(fc,3)+zmdst4 ! (combo) #ifdef MODAL_AER !mgf++ bugfix - rds(c,3) = (rds(c,3)*(swliq(c,3)+swice(c,3)) + rds(c,2)*(zwliq+zwice))/(swliq(c,3)+swice(c,3)+zwliq+zwice) - if ((rds(c,3) < 30.) .or. (rds(c,3) > 1500.)) then + rds(fc,3) = (rds(fc,3)*(swliq(fc,3)+swice(fc,3)) + rds(fc,2)*(zwliq+zwice))/(swliq(fc,3)+swice(fc,3)+zwliq+zwice) + if ((rds(fc,3) < 30.) .or. (rds(fc,3) > 1500.)) then #ifndef _OPENACC - write (iulog,*) "3. SNICAR ERROR: snow grain radius of",rds(c,3),rds(c,2) - write (iulog,*) "swliq, swice, zwliq, zwice", swliq(c,3), swice(c,3),zwliq, zwice + write (iulog,*) "3. SNICAR ERROR: snow grain radius of",rds(fc,3),rds(fc,2) + write (iulog,*) "swliq, swice, zwliq, zwice", swliq(fc,3), swice(fc,3),zwliq, zwice write (iulog,*) "layers ", msno #endif endif !mgf-- #else - rds(c,3) = rds(c,2) ! (combo) + rds(fc,3) = rds(fc,2) ! (combo) #endif - call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, & - zwliq, zwice, tsno(c,2)) + call Combo (dzsno(fc,3), swliq(fc,3), swice(fc,3), tsno(fc,3), drr, & + zwliq, zwice, tsno(fc,2)) ! Subdivided a new layer if (is_lake) then @@ -1511,39 +1696,39 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (msno <= 3 .and. dzsno(c,3) > 0.18_r8+offset) then + if (msno <= 3 .and. dzsno(fc,3) > 0.18_r8+offset) then msno = 4 - dtdz = (tsno(c,2) - tsno(c,3))/((dzsno(c,2)+dzsno(c,3))/2._r8) - dzsno(c,3) = dzsno(c,3)/2._r8 - swice(c,3) = swice(c,3)/2._r8 - swliq(c,3) = swliq(c,3)/2._r8 - dzsno(c,4) = dzsno(c,3) - swice(c,4) = swice(c,3) - swliq(c,4) = swliq(c,3) - tsno(c,4) = tsno(c,3) - dtdz*dzsno(c,3)/2._r8 - if (tsno(c,4) >= tfrz) then - tsno(c,4) = tsno(c,3) + dtdz = (tsno(fc,2) - tsno(fc,3))/((dzsno(fc,2)+dzsno(fc,3))/2._r8) + dzsno(fc,3) = dzsno(fc,3)/2._r8 + swice(fc,3) = swice(fc,3)/2._r8 + swliq(fc,3) = swliq(fc,3)/2._r8 + dzsno(fc,4) = dzsno(fc,3) + swice(fc,4) = swice(fc,3) + swliq(fc,4) = swliq(fc,3) + tsno(fc,4) = tsno(fc,3) - dtdz*dzsno(fc,3)/2._r8 + if (tsno(fc,4) >= tfrz) then + tsno(fc,4) = tsno(fc,3) else - tsno(c,3) = tsno(c,3) + dtdz*dzsno(c,3)/2._r8 + tsno(fc,3) = tsno(fc,3) + dtdz*dzsno(fc,3)/2._r8 endif - mbc_phi(c,3) = mbc_phi(c,3)/2._r8 - mbc_phi(c,4) = mbc_phi(c,3) - mbc_pho(c,3) = mbc_pho(c,3)/2._r8 - mbc_pho(c,4) = mbc_pho(c,3) - moc_phi(c,3) = moc_phi(c,3)/2._r8 - moc_phi(c,4) = moc_phi(c,3) - moc_pho(c,3) = moc_pho(c,3)/2._r8 - moc_pho(c,4) = moc_pho(c,3) - mdst1(c,3) = mdst1(c,3)/2._r8 - mdst1(c,4) = mdst1(c,3) - mdst2(c,3) = mdst2(c,3)/2._r8 - mdst2(c,4) = mdst2(c,3) - mdst3(c,3) = mdst3(c,3)/2._r8 - mdst3(c,4) = mdst3(c,3) - mdst4(c,3) = mdst4(c,3)/2._r8 - mdst4(c,4) = mdst4(c,3) - rds(c,4) = rds(c,3) + mbc_phi(fc,3) = mbc_phi(fc,3)/2._r8 + mbc_phi(fc,4) = mbc_phi(fc,3) + mbc_pho(fc,3) = mbc_pho(fc,3)/2._r8 + mbc_pho(fc,4) = mbc_pho(fc,3) + moc_phi(fc,3) = moc_phi(fc,3)/2._r8 + moc_phi(fc,4) = moc_phi(fc,3) + moc_pho(fc,3) = moc_pho(fc,3)/2._r8 + moc_pho(fc,4) = moc_pho(fc,3) + mdst1(fc,3) = mdst1(fc,3)/2._r8 + mdst1(fc,4) = mdst1(fc,3) + mdst2(fc,3) = mdst2(fc,3)/2._r8 + mdst2(fc,4) = mdst2(fc,3) + mdst3(fc,3) = mdst3(fc,3)/2._r8 + mdst3(fc,4) = mdst3(fc,3) + mdst4(fc,3) = mdst4(fc,3)/2._r8 + mdst4(fc,4) = mdst4(fc,3) + rds(fc,4) = rds(fc,3) end if end if @@ -1555,71 +1740,71 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (dzsno(c,3) > 0.11_r8 + offset) then + if (dzsno(fc,3) > 0.11_r8 + offset) then if (is_lake) then - drr = dzsno(c,3) - 0.11_r8 - lsadz + drr = dzsno(fc,3) - 0.11_r8 - lsadz else - drr = dzsno(c,3) - 0.11_r8 + drr = dzsno(fc,3) - 0.11_r8 end if - propor = drr/dzsno(c,3) - zwice = propor*swice(c,3) - zwliq = propor*swliq(c,3) - - zmbc_phi = propor*mbc_phi(c,3) - zmbc_pho = propor*mbc_pho(c,3) - zmoc_phi = propor*moc_phi(c,3) - zmoc_pho = propor*moc_pho(c,3) - zmdst1 = propor*mdst1(c,3) - zmdst2 = propor*mdst2(c,3) - zmdst3 = propor*mdst3(c,3) - zmdst4 = propor*mdst4(c,3) + propor = drr/dzsno(fc,3) + zwice = propor*swice(fc,3) + zwliq = propor*swliq(fc,3) + + zmbc_phi = propor*mbc_phi(fc,3) + zmbc_pho = propor*mbc_pho(fc,3) + zmoc_phi = propor*moc_phi(fc,3) + zmoc_pho = propor*moc_pho(fc,3) + zmdst1 = propor*mdst1(fc,3) + zmdst2 = propor*mdst2(fc,3) + zmdst3 = propor*mdst3(fc,3) + zmdst4 = propor*mdst4(fc,3) if (is_lake) then - propor = (0.11_r8+lsadz)/dzsno(c,3) + propor = (0.11_r8+lsadz)/dzsno(fc,3) else - propor = 0.11_r8/dzsno(c,3) + propor = 0.11_r8/dzsno(fc,3) end if - swice(c,3) = propor*swice(c,3) - swliq(c,3) = propor*swliq(c,3) - - mbc_phi(c,3) = propor*mbc_phi(c,3) - mbc_pho(c,3) = propor*mbc_pho(c,3) - moc_phi(c,3) = propor*moc_phi(c,3) - moc_pho(c,3) = propor*moc_pho(c,3) - mdst1(c,3) = propor*mdst1(c,3) - mdst2(c,3) = propor*mdst2(c,3) - mdst3(c,3) = propor*mdst3(c,3) - mdst4(c,3) = propor*mdst4(c,3) + swice(fc,3) = propor*swice(fc,3) + swliq(fc,3) = propor*swliq(fc,3) + + mbc_phi(fc,3) = propor*mbc_phi(fc,3) + mbc_pho(fc,3) = propor*mbc_pho(fc,3) + moc_phi(fc,3) = propor*moc_phi(fc,3) + moc_pho(fc,3) = propor*moc_pho(fc,3) + mdst1(fc,3) = propor*mdst1(fc,3) + mdst2(fc,3) = propor*mdst2(fc,3) + mdst3(fc,3) = propor*mdst3(fc,3) + mdst4(fc,3) = propor*mdst4(fc,3) if (is_lake) then - dzsno(c,3) = 0.11_r8 + lsadz + dzsno(fc,3) = 0.11_r8 + lsadz else - dzsno(c,3) = 0.11_r8 + dzsno(fc,3) = 0.11_r8 end if - mbc_phi(c,4) = mbc_phi(c,4)+zmbc_phi ! (combo) - mbc_pho(c,4) = mbc_pho(c,4)+zmbc_pho ! (combo) - moc_phi(c,4) = moc_phi(c,4)+zmoc_phi ! (combo) - moc_pho(c,4) = moc_pho(c,4)+zmoc_pho ! (combo) - mdst1(c,4) = mdst1(c,4)+zmdst1 ! (combo) - mdst2(c,4) = mdst2(c,4)+zmdst2 ! (combo) - mdst3(c,4) = mdst3(c,4)+zmdst3 ! (combo) - mdst4(c,4) = mdst4(c,4)+zmdst4 ! (combo) + mbc_phi(fc,4) = mbc_phi(fc,4)+zmbc_phi ! (combo) + mbc_pho(fc,4) = mbc_pho(fc,4)+zmbc_pho ! (combo) + moc_phi(fc,4) = moc_phi(fc,4)+zmoc_phi ! (combo) + moc_pho(fc,4) = moc_pho(fc,4)+zmoc_pho ! (combo) + mdst1(fc,4) = mdst1(fc,4)+zmdst1 ! (combo) + mdst2(fc,4) = mdst2(fc,4)+zmdst2 ! (combo) + mdst3(fc,4) = mdst3(fc,4)+zmdst3 ! (combo) + mdst4(fc,4) = mdst4(fc,4)+zmdst4 ! (combo) #ifdef MODAL_AER !mgf++ bugfix - rds(c,4) = (rds(c,4)*(swliq(c,4)+swice(c,4)) + rds(c,3)*(zwliq+zwice))/(swliq(c,4)+swice(c,4)+zwliq+zwice) - if ((rds(c,4) < 30.) .or. (rds(c,4) > 1500.)) then - write (iulog,*) "4. SNICAR ERROR: snow grain radius of",rds(c,4),rds(c,3) - write (iulog,*) "swliq, swice, zwliq, zwice", swliq(c,4), swice(c,4),zwliq, zwice + rds(fc,4) = (rds(fc,4)*(swliq(fc,4)+swice(fc,4)) + rds(fc,3)*(zwliq+zwice))/(swliq(fc,4)+swice(fc,4)+zwliq+zwice) + if ((rds(fc,4) < 30.) .or. (rds(fc,4) > 1500.)) then + write (iulog,*) "4. SNICAR ERROR: snow grain radius of",rds(fc,4),rds(fc,3) + write (iulog,*) "swliq, swice, zwliq, zwice", swliq(fc,4), swice(fc,4),zwliq, zwice write (iulog,*) "layers ", msno endif !mgf-- #else - rds(c,4) = rds(c,3) ! (combo) + rds(fc,4) = rds(fc,3) ! (combo) #endif - call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, & - zwliq, zwice, tsno(c,3)) + call Combo (dzsno(fc,4), swliq(fc,4), swice(fc,4), tsno(fc,4), drr, & + zwliq, zwice, tsno(fc,3)) ! Subdivided a new layer if (is_lake) then @@ -1627,39 +1812,39 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (msno <= 4 .and. dzsno(c,4) > 0.41_r8 + offset) then + if (msno <= 4 .and. dzsno(fc,4) > 0.41_r8 + offset) then msno = 5 - dtdz = (tsno(c,3) - tsno(c,4))/((dzsno(c,3)+dzsno(c,4))/2._r8) - dzsno(c,4) = dzsno(c,4)/2._r8 - swice(c,4) = swice(c,4)/2._r8 - swliq(c,4) = swliq(c,4)/2._r8 - dzsno(c,5) = dzsno(c,4) - swice(c,5) = swice(c,4) - swliq(c,5) = swliq(c,4) - tsno(c,5) = tsno(c,4) - dtdz*dzsno(c,4)/2._r8 - if (tsno(c,5) >= tfrz) then - tsno(c,5) = tsno(c,4) + dtdz = (tsno(fc,3) - tsno(fc,4))/((dzsno(fc,3)+dzsno(fc,4))/2._r8) + dzsno(fc,4) = dzsno(fc,4)/2._r8 + swice(fc,4) = swice(fc,4)/2._r8 + swliq(fc,4) = swliq(fc,4)/2._r8 + dzsno(fc,5) = dzsno(fc,4) + swice(fc,5) = swice(fc,4) + swliq(fc,5) = swliq(fc,4) + tsno(fc,5) = tsno(fc,4) - dtdz*dzsno(fc,4)/2._r8 + if (tsno(fc,5) >= tfrz) then + tsno(fc,5) = tsno(fc,4) else - tsno(c,4) = tsno(c,4) + dtdz*dzsno(c,4)/2._r8 + tsno(fc,4) = tsno(fc,4) + dtdz*dzsno(fc,4)/2._r8 endif - mbc_phi(c,4) = mbc_phi(c,4)/2._r8 - mbc_phi(c,5) = mbc_phi(c,4) - mbc_pho(c,4) = mbc_pho(c,4)/2._r8 - mbc_pho(c,5) = mbc_pho(c,4) - moc_phi(c,4) = moc_phi(c,4)/2._r8 - moc_phi(c,5) = moc_phi(c,4) - moc_pho(c,4) = moc_pho(c,4)/2._r8 - moc_pho(c,5) = moc_pho(c,4) - mdst1(c,4) = mdst1(c,4)/2._r8 - mdst1(c,5) = mdst1(c,4) - mdst2(c,4) = mdst2(c,4)/2._r8 - mdst2(c,5) = mdst2(c,4) - mdst3(c,4) = mdst3(c,4)/2._r8 - mdst3(c,5) = mdst3(c,4) - mdst4(c,4) = mdst4(c,4)/2._r8 - mdst4(c,5) = mdst4(c,4) - rds(c,5) = rds(c,4) + mbc_phi(fc,4) = mbc_phi(fc,4)/2._r8 + mbc_phi(fc,5) = mbc_phi(fc,4) + mbc_pho(fc,4) = mbc_pho(fc,4)/2._r8 + mbc_pho(fc,5) = mbc_pho(fc,4) + moc_phi(fc,4) = moc_phi(fc,4)/2._r8 + moc_phi(fc,5) = moc_phi(fc,4) + moc_pho(fc,4) = moc_pho(fc,4)/2._r8 + moc_pho(fc,5) = moc_pho(fc,4) + mdst1(fc,4) = mdst1(fc,4)/2._r8 + mdst1(fc,5) = mdst1(fc,4) + mdst2(fc,4) = mdst2(fc,4)/2._r8 + mdst2(fc,5) = mdst2(fc,4) + mdst3(fc,4) = mdst3(fc,4)/2._r8 + mdst3(fc,5) = mdst3(fc,4) + mdst4(fc,4) = mdst4(fc,4)/2._r8 + mdst4(fc,5) = mdst4(fc,4) + rds(fc,5) = rds(fc,4) end if end if @@ -1671,71 +1856,71 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & else offset = 0._r8 end if - if (dzsno(c,4) > 0.23_r8+offset) then + if (dzsno(fc,4) > 0.23_r8+offset) then if (is_lake) then - drr = dzsno(c,4) - 0.23_r8 - lsadz + drr = dzsno(fc,4) - 0.23_r8 - lsadz else - drr = dzsno(c,4) - 0.23_r8 + drr = dzsno(fc,4) - 0.23_r8 end if - propor = drr/dzsno(c,4) - zwice = propor*swice(c,4) - zwliq = propor*swliq(c,4) - - zmbc_phi = propor*mbc_phi(c,4) - zmbc_pho = propor*mbc_pho(c,4) - zmoc_phi = propor*moc_phi(c,4) - zmoc_pho = propor*moc_pho(c,4) - zmdst1 = propor*mdst1(c,4) - zmdst2 = propor*mdst2(c,4) - zmdst3 = propor*mdst3(c,4) - zmdst4 = propor*mdst4(c,4) + propor = drr/dzsno(fc,4) + zwice = propor*swice(fc,4) + zwliq = propor*swliq(fc,4) + + zmbc_phi = propor*mbc_phi(fc,4) + zmbc_pho = propor*mbc_pho(fc,4) + zmoc_phi = propor*moc_phi(fc,4) + zmoc_pho = propor*moc_pho(fc,4) + zmdst1 = propor*mdst1(fc,4) + zmdst2 = propor*mdst2(fc,4) + zmdst3 = propor*mdst3(fc,4) + zmdst4 = propor*mdst4(fc,4) if (is_lake) then - propor = (0.23_r8+lsadz)/dzsno(c,4) + propor = (0.23_r8+lsadz)/dzsno(fc,4) else - propor = 0.23_r8/dzsno(c,4) + propor = 0.23_r8/dzsno(fc,4) end if - swice(c,4) = propor*swice(c,4) - swliq(c,4) = propor*swliq(c,4) - - mbc_phi(c,4) = propor*mbc_phi(c,4) - mbc_pho(c,4) = propor*mbc_pho(c,4) - moc_phi(c,4) = propor*moc_phi(c,4) - moc_pho(c,4) = propor*moc_pho(c,4) - mdst1(c,4) = propor*mdst1(c,4) - mdst2(c,4) = propor*mdst2(c,4) - mdst3(c,4) = propor*mdst3(c,4) - mdst4(c,4) = propor*mdst4(c,4) + swice(fc,4) = propor*swice(fc,4) + swliq(fc,4) = propor*swliq(fc,4) + + mbc_phi(fc,4) = propor*mbc_phi(fc,4) + mbc_pho(fc,4) = propor*mbc_pho(fc,4) + moc_phi(fc,4) = propor*moc_phi(fc,4) + moc_pho(fc,4) = propor*moc_pho(fc,4) + mdst1(fc,4) = propor*mdst1(fc,4) + mdst2(fc,4) = propor*mdst2(fc,4) + mdst3(fc,4) = propor*mdst3(fc,4) + mdst4(fc,4) = propor*mdst4(fc,4) if (is_lake) then - dzsno(c,4) = 0.23_r8 + lsadz + dzsno(fc,4) = 0.23_r8 + lsadz else - dzsno(c,4) = 0.23_r8 + dzsno(fc,4) = 0.23_r8 end if - mbc_phi(c,5) = mbc_phi(c,5)+zmbc_phi ! (combo) - mbc_pho(c,5) = mbc_pho(c,5)+zmbc_pho ! (combo) - moc_phi(c,5) = moc_phi(c,5)+zmoc_phi ! (combo) - moc_pho(c,5) = moc_pho(c,5)+zmoc_pho ! (combo) - mdst1(c,5) = mdst1(c,5)+zmdst1 ! (combo) - mdst2(c,5) = mdst2(c,5)+zmdst2 ! (combo) - mdst3(c,5) = mdst3(c,5)+zmdst3 ! (combo) - mdst4(c,5) = mdst4(c,5)+zmdst4 ! (combo) + mbc_phi(fc,5) = mbc_phi(fc,5)+zmbc_phi ! (combo) + mbc_pho(fc,5) = mbc_pho(fc,5)+zmbc_pho ! (combo) + moc_phi(fc,5) = moc_phi(fc,5)+zmoc_phi ! (combo) + moc_pho(fc,5) = moc_pho(fc,5)+zmoc_pho ! (combo) + mdst1(fc,5) = mdst1(fc,5)+zmdst1 ! (combo) + mdst2(fc,5) = mdst2(fc,5)+zmdst2 ! (combo) + mdst3(fc,5) = mdst3(fc,5)+zmdst3 ! (combo) + mdst4(fc,5) = mdst4(fc,5)+zmdst4 ! (combo) #ifdef MODAL_AER !mgf++ bugfix - rds(c,5) = (rds(c,5)*(swliq(c,5)+swice(c,5)) + rds(c,4)*(zwliq+zwice))/(swliq(c,5)+swice(c,5)+zwliq+zwice) - if ((rds(c,5) < 30.) .or. (rds(c,5) > 1500.)) then + rds(fc,5) = (rds(fc,5)*(swliq(fc,5)+swice(fc,5)) + rds(fc,4)*(zwliq+zwice))/(swliq(fc,5)+swice(fc,5)+zwliq+zwice) + if ((rds(fc,5) < 30.) .or. (rds(fc,5) > 1500.)) then write (iulog,*) "5. SNICAR ERROR: snow grain radius of",rds(c,5),rds(c,4) write (iulog,*) "swliq, swice, zwliq, zwice", swliq(c,5), swice(c,5),zwliq, zwice write (iulog,*) "layers ", msno endif !mgf-- #else - rds(c,5) = rds(c,4) ! (combo) + rds(fc,5) = rds(fc,4) ! (combo) #endif - call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, & - zwliq, zwice, tsno(c,4)) + call Combo (dzsno(fc,5), swliq(fc,5), swice(fc,5), tsno(fc,5), drr, & + zwliq, zwice, tsno(fc,4)) end if end if @@ -1743,27 +1928,28 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & end do + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1,0 do fc = 1, num_snowc c = filter_snowc(fc) if (j >= snl(c)+1) then if (is_lake) then - dz(c,j) = dzsno(c,j-snl(c)) + dz(c,j) = dzsno(fc,j-snl(c)) else - dz(c,j) = dzsno(c,j-snl(c))/frac_sno(c) + dz(c,j) = dzsno(fc,j-snl(c))/frac_sno(c) end if - h2osoi_ice(c,j) = swice(c,j-snl(c)) - h2osoi_liq(c,j) = swliq(c,j-snl(c)) - t_soisno(c,j) = tsno(c,j-snl(c)) - mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) - mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) - mss_ocphi(c,j) = moc_phi(c,j-snl(c)) - mss_ocpho(c,j) = moc_pho(c,j-snl(c)) - mss_dst1(c,j) = mdst1(c,j-snl(c)) - mss_dst2(c,j) = mdst2(c,j-snl(c)) - mss_dst3(c,j) = mdst3(c,j-snl(c)) - mss_dst4(c,j) = mdst4(c,j-snl(c)) - snw_rds(c,j) = rds(c,j-snl(c)) + h2osoi_ice(c,j) = swice(fc,j-snl(c)) + h2osoi_liq(c,j) = swliq(fc,j-snl(c)) + t_soisno(c,j) = tsno(fc,j-snl(c)) + mss_bcphi(c,j) = mbc_phi(fc,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(fc,j-snl(c)) + mss_ocphi(c,j) = moc_phi(fc,j-snl(c)) + mss_ocpho(c,j) = moc_pho(fc,j-snl(c)) + mss_dst1(c,j) = mdst1(fc,j-snl(c)) + mss_dst2(c,j) = mdst2(fc,j-snl(c)) + mss_dst3(c,j) = mdst3(fc,j-snl(c)) + mss_dst4(c,j) = mdst4(fc,j-snl(c)) + snw_rds(c,j) = rds(fc,j-snl(c)) end if end do @@ -1771,28 +1957,31 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & ! Consistency check if (is_lake) then - do j = -nlevsno + 1, 0 - do fc = 1, num_snowc - c = filter_snowc(fc) + + do fc = 1, num_snowc + c = filter_snowc(fc) + + do j = -nlevsno + 1, 0 if (j >= snl(c)+1) then - dztot(c) = dztot(c) - dz(c,j) - snwicetot(c) = snwicetot(c) - h2osoi_ice(c,j) - snwliqtot(c) = snwliqtot(c) - h2osoi_liq(c,j) + dztot(fc) = dztot(fc) - dz(c,j) + snwicetot(fc) = snwicetot(fc) - h2osoi_ice(c,j) + snwliqtot(fc) = snwliqtot(fc) - h2osoi_liq(c,j) end if if (j == 0) then - if ( abs(dztot(c)) > 1.e-10_r8 .or. abs(snwicetot(c)) > 1.e-7_r8 .or. & - abs(snwliqtot(c)) > 1.e-7_r8 ) then + if ( abs(dztot(fc)) > 1.e-10_r8 .or. abs(snwicetot(fc)) > 1.e-7_r8 .or. & + abs(snwliqtot(fc)) > 1.e-7_r8 ) then write(iulog,*)'Inconsistency in SnowDivision_Lake! c, remainders', & 'dztot, snwicetot, snwliqtot = ',c,dztot(c),snwicetot(c),snwliqtot(c) call endrun(decomp_index=c, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) end if end if - end do - end do + end do + end do end if + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 0, -nlevsno+1, -1 do fc = 1, num_snowc c = filter_snowc(fc) @@ -1803,6 +1992,27 @@ subroutine DivideSnowLayers(bounds, num_snowc, filter_snowc, & end do end do + !$acc exit data delete(& + !$acc dzsno(:,:), & + !$acc swice(:,:), & + !$acc swliq(:,:), & + !$acc tsno(:,:), & + !$acc mbc_phi(:,:), & + !$acc mbc_pho(:,:), & + !$acc moc_phi(:,:), & + !$acc moc_pho(:,:), & + !$acc mdst1(:,:), & + !$acc mdst2(:,:), & + !$acc mdst3(:,:), & + !$acc mdst4(:,:), & + !$acc rds(:,:), & + !$acc dztot(:), & + !$acc snwicetot(:), & + !$acc snwliqtot(:), & + !$acc sum1, & + !$acc sum2, & + !$acc sum3) + end associate end subroutine DivideSnowLayers @@ -1830,36 +2040,36 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & integer :: j, c, fc, k ! indices real(r8) :: drr ! thickness of the combined [m] integer :: msno ! number of snow layer 1 (top) to msno (bottom) - real(r8) :: dzsno(bounds%begc:bounds%endc,nlevsno) ! Snow layer thickness [m] - real(r8) :: swice(bounds%begc:bounds%endc,nlevsno) ! Partial volume of ice [m3/m3] - real(r8) :: swliq(bounds%begc:bounds%endc,nlevsno) ! Partial volume of liquid water [m3/m3] - real(r8) :: tsno(bounds%begc:bounds%endc ,nlevsno) ! Nodel temperature [K] + real(r8) :: dzsno(1:num_snowc,nlevsno) ! Snow layer thickness [m] + real(r8) :: swice(1:num_snowc,nlevsno) ! Partial volume of ice [m3/m3] + real(r8) :: swliq(1:num_snowc,nlevsno) ! Partial volume of liquid water [m3/m3] + real(r8) :: tsno(1:num_snowc ,nlevsno) ! Nodel temperature [K] real(r8) :: zwice ! temporary real(r8) :: zwliq ! temporary real(r8) :: propor ! temporary real(r8) :: dtdz ! temporary ! temporary variables mimicking the structure of other layer division variables - real(r8) :: mbc_phi(bounds%begc:bounds%endc,nlevsno) ! mass of BC in each snow layer + real(r8) :: mbc_phi(1:num_snowc,nlevsno) ! mass of BC in each snow layer real(r8) :: zmbc_phi ! temporary - real(r8) :: mbc_pho(bounds%begc:bounds%endc,nlevsno) ! mass of BC in each snow layer + real(r8) :: mbc_pho(1:num_snowc,nlevsno) ! mass of BC in each snow layer real(r8) :: zmbc_pho ! temporary - real(r8) :: moc_phi(bounds%begc:bounds%endc,nlevsno) ! mass of OC in each snow layer + real(r8) :: moc_phi(1:num_snowc,nlevsno) ! mass of OC in each snow layer real(r8) :: zmoc_phi ! temporary - real(r8) :: moc_pho(bounds%begc:bounds%endc,nlevsno) ! mass of OC in each snow layer + real(r8) :: moc_pho(1:num_snowc,nlevsno) ! mass of OC in each snow layer real(r8) :: zmoc_pho ! temporary - real(r8) :: mdst1(bounds%begc:bounds%endc,nlevsno) ! mass of dust 1 in each snow layer + real(r8) :: mdst1(1:num_snowc,nlevsno) ! mass of dust 1 in each snow layer real(r8) :: zmdst1 ! temporary - real(r8) :: mdst2(bounds%begc:bounds%endc,nlevsno) ! mass of dust 2 in each snow layer + real(r8) :: mdst2(1:num_snowc,nlevsno) ! mass of dust 2 in each snow layer real(r8) :: zmdst2 ! temporary - real(r8) :: mdst3(bounds%begc:bounds%endc,nlevsno) ! mass of dust 3 in each snow layer + real(r8) :: mdst3(1:num_snowc,nlevsno) ! mass of dust 3 in each snow layer real(r8) :: zmdst3 ! temporary - real(r8) :: mdst4(bounds%begc:bounds%endc,nlevsno) ! mass of dust 4 in each snow layer + real(r8) :: mdst4(1:num_snowc,nlevsno) ! mass of dust 4 in each snow layer real(r8) :: zmdst4 ! temporary - real(r8) :: rds(bounds%begc:bounds%endc,nlevsno) + real(r8) :: rds(1:num_snowc,nlevsno) ! Variables for consistency check - real(r8) :: dztot(bounds%begc:bounds%endc) - real(r8) :: snwicetot(bounds%begc:bounds%endc) - real(r8) :: snwliqtot(bounds%begc:bounds%endc) + real(r8) :: dztot(1:num_snowc) + real(r8) :: snwicetot(1:num_snowc) + real(r8) :: snwliqtot(1:num_snowc) real(r8) :: offset ! temporary !----------------------------------------------------------------------- @@ -1885,6 +2095,27 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & zi => col_pp%zi , & ! Output: [real(r8) (:,:) ] interface level below a "z" level (m) z => col_pp%z & ! Output: [real(r8) (:,:) ] layer thickness (m) ) + !$acc enter data create(& + !$acc dzsno(:,:), & + !$acc swice(:,:), & + !$acc swliq(:,:), & + !$acc tsno(:,:), & + !$acc mbc_phi(:,:), & + !$acc mbc_pho(:,:), & + !$acc moc_phi(:,:), & + !$acc moc_pho(:,:), & + !$acc mdst1(:,:), & + !$acc mdst2(:,:), & + !$acc mdst3(:,:), & + !$acc mdst4(:,:), & + !$acc rds(:,:), & + !$acc dztot(:), & + !$acc snwicetot(:), & + !$acc snwliqtot(:), & + !$acc msno) + + + if ( is_lake ) then ! Initialize for consistency check @@ -1893,15 +2124,15 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & c = filter_snowc(fc) if (j == -nlevsno+1) then - dztot(c) = 0._r8 - snwicetot(c) = 0._r8 - snwliqtot(c) = 0._r8 + dztot(fc) = 0._r8 + snwicetot(fc) = 0._r8 + snwliqtot(fc) = 0._r8 end if if (j >= snl(c)+1) then - dztot(c) = dztot(c) + dz(c,j) - snwicetot(c) = snwicetot(c) + h2osoi_ice(c,j) - snwliqtot(c) = snwliqtot(c) + h2osoi_liq(c,j) + dztot(fc) = dztot(fc) + dz(c,j) + snwicetot(fc) = snwicetot(fc) + h2osoi_ice(c,j) + snwliqtot(fc) = snwliqtot(fc) + h2osoi_liq(c,j) end if end do end do @@ -1910,32 +2141,34 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & ! Begin calculation - note that the following column loops are only invoked ! for snow-covered columns + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1,nlevsno do fc = 1, num_snowc c = filter_snowc(fc) if (j <= abs(snl(c))) then if (is_lake) then - dzsno(c,j) = dz(c,j+snl(c)) + dzsno(fc,j) = dz(c,j+snl(c)) else - dzsno(c,j) = frac_sno(c)*dz(c,j+snl(c)) + dzsno(fc,j) = frac_sno(c)*dz(c,j+snl(c)) end if - swice(c,j) = h2osoi_ice(c,j+snl(c)) - swliq(c,j) = h2osoi_liq(c,j+snl(c)) - tsno(c,j) = t_soisno(c,j+snl(c)) - - mbc_phi(c,j) = mss_bcphi(c,j+snl(c)) - mbc_pho(c,j) = mss_bcpho(c,j+snl(c)) - moc_phi(c,j) = mss_ocphi(c,j+snl(c)) - moc_pho(c,j) = mss_ocpho(c,j+snl(c)) - mdst1(c,j) = mss_dst1(c,j+snl(c)) - mdst2(c,j) = mss_dst2(c,j+snl(c)) - mdst3(c,j) = mss_dst3(c,j+snl(c)) - mdst4(c,j) = mss_dst4(c,j+snl(c)) - rds(c,j) = snw_rds(c,j+snl(c)) + swice(fc,j) = h2osoi_ice(c,j+snl(c)) + swliq(fc,j) = h2osoi_liq(c,j+snl(c)) + tsno(fc,j) = t_soisno(c,j+snl(c)) + + mbc_phi(fc,j) = mss_bcphi(c,j+snl(c)) + mbc_pho(fc,j) = mss_bcpho(c,j+snl(c)) + moc_phi(fc,j) = mss_ocphi(c,j+snl(c)) + moc_pho(fc,j) = mss_ocpho(c,j+snl(c)) + mdst1(fc,j) = mss_dst1(c,j+snl(c)) + mdst2(fc,j) = mss_dst2(c,j+snl(c)) + mdst3(fc,j) = mss_dst3(c,j+snl(c)) + mdst4(fc,j) = mss_dst4(c,j+snl(c)) + rds(fc,j) = snw_rds(c,j+snl(c)) end if end do end do + !$acc parallel loop independent gang vector default(present) loop_snowcolumns: do fc = 1, num_snowc c = filter_snowc(fc) @@ -1957,49 +2190,49 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & offset = 0._r8 end if - if (dzsno(c,k) > dzmax_l(k) + offset) then + if (dzsno(fc,k) > dzmax_l(k) + offset) then ! Subdivide layer into two layers with equal thickness, water ! content, ice content and temperature msno = msno + 1 - dzsno(c,k) = dzsno(c,k) / 2.0_r8 - dzsno(c,k+1) = dzsno(c,k) - swice(c,k) = swice(c,k) / 2.0_r8 - swice(c,k+1) = swice(c,k) - swliq(c,k) = swliq(c,k) / 2.0_r8 - swliq(c,k+1) = swliq(c,k) + dzsno(fc,k) = dzsno(fc,k) / 2.0_r8 + dzsno(fc,k+1) = dzsno(fc,k) + swice(fc,k) = swice(fc,k) / 2.0_r8 + swice(fc,k+1) = swice(fc,k) + swliq(fc,k) = swliq(fc,k) / 2.0_r8 + swliq(fc,k+1) = swliq(fc,k) if (k == 1) then ! special case - tsno(c,k+1) = tsno(c,k) + tsno(fc,k+1) = tsno(fc,k) else ! use temperature gradient - dtdz = (tsno(c,k-1) - tsno(c,k))/((dzsno(c,k-1)+2*dzsno(c,k))/2.0_r8) - tsno(c,k+1) = tsno(c,k) - dtdz*dzsno(c,k)/2.0_r8 - if (tsno(c,k+1) >= tfrz) then - tsno(c,k+1) = tsno(c,k) + dtdz = (tsno(fc,k-1) - tsno(fc,k))/((dzsno(fc,k-1)+2*dzsno(fc,k))/2.0_r8) + tsno(fc,k+1) = tsno(fc,k) - dtdz*dzsno(fc,k)/2.0_r8 + if (tsno(fc,k+1) >= tfrz) then + tsno(fc,k+1) = tsno(fc,k) else - tsno(c,k) = tsno(c,k) + dtdz*dzsno(c,k)/2.0_r8 + tsno(fc,k) = tsno(fc,k) + dtdz*dzsno(fc,k)/2.0_r8 endif end if - mbc_phi(c,k) = mbc_phi(c,k) / 2.0_r8 - mbc_phi(c,k+1) = mbc_phi(c,k) - mbc_pho(c,k) = mbc_pho(c,k) / 2.0_r8 - mbc_pho(c,k+1) = mbc_pho(c,k) - moc_phi(c,k) = moc_phi(c,k) / 2.0_r8 - moc_phi(c,k+1) = moc_phi(c,k) - moc_pho(c,k) = moc_pho(c,k) / 2.0_r8 - moc_pho(c,k+1) = moc_pho(c,k) - mdst1(c,k) = mdst1(c,k) / 2.0_r8 - mdst1(c,k+1) = mdst1(c,k) - mdst2(c,k) = mdst2(c,k) / 2.0_r8 - mdst2(c,k+1) = mdst2(c,k) - mdst3(c,k) = mdst3(c,k) / 2.0_r8 - mdst3(c,k+1) = mdst3(c,k) - mdst4(c,k) = mdst4(c,k) / 2.0_r8 - mdst4(c,k+1) = mdst4(c,k) - - rds(c,k+1) = rds(c,k) + mbc_phi(fc,k) = mbc_phi(fc,k) / 2.0_r8 + mbc_phi(fc,k+1) = mbc_phi(fc,k) + mbc_pho(fc,k) = mbc_pho(fc,k) / 2.0_r8 + mbc_pho(fc,k+1) = mbc_pho(fc,k) + moc_phi(fc,k) = moc_phi(fc,k) / 2.0_r8 + moc_phi(fc,k+1) = moc_phi(fc,k) + moc_pho(fc,k) = moc_pho(fc,k) / 2.0_r8 + moc_pho(fc,k+1) = moc_pho(fc,k) + mdst1(fc,k) = mdst1(fc,k) / 2.0_r8 + mdst1(fc,k+1) = mdst1(fc,k) + mdst2(fc,k) = mdst2(fc,k) / 2.0_r8 + mdst2(fc,k+1) = mdst2(fc,k) + mdst3(fc,k) = mdst3(fc,k) / 2.0_r8 + mdst3(fc,k+1) = mdst3(fc,k) + mdst4(fc,k) = mdst4(fc,k) / 2.0_r8 + mdst4(fc,k+1) = mdst4(fc,k) + + rds(fc,k+1) = rds(fc,k) end if end if @@ -2013,53 +2246,53 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & offset = 0._r8 end if - if (dzsno(c,k) > dzmax_u(k) + offset ) then + if (dzsno(fc,k) > dzmax_u(k) + offset ) then ! Only dump excess snow to underlying layer in a conservative fashion. ! Other quantities will depend on the height of the excess snow: a ratio is used for this. - drr = dzsno(c,k) - dzmax_u(k) - offset - - propor = drr/dzsno(c,k) - zwice = propor*swice(c,k) - zwliq = propor*swliq(c,k) - zmbc_phi = propor*mbc_phi(c,k) - zmbc_pho = propor*mbc_pho(c,k) - zmoc_phi = propor*moc_phi(c,k) - zmoc_pho = propor*moc_pho(c,k) - zmdst1 = propor*mdst1(c,k) - zmdst2 = propor*mdst2(c,k) - zmdst3 = propor*mdst3(c,k) - zmdst4 = propor*mdst4(c,k) - - propor = (dzmax_u(k)+offset)/dzsno(c,k) - swice(c,k) = propor*swice(c,k) - swliq(c,k) = propor*swliq(c,k) - mbc_phi(c,k) = propor*mbc_phi(c,k) - mbc_pho(c,k) = propor*mbc_pho(c,k) - moc_phi(c,k) = propor*moc_phi(c,k) - moc_pho(c,k) = propor*moc_pho(c,k) - mdst1(c,k) = propor*mdst1(c,k) - mdst2(c,k) = propor*mdst2(c,k) - mdst3(c,k) = propor*mdst3(c,k) - mdst4(c,k) = propor*mdst4(c,k) + drr = dzsno(fc,k) - dzmax_u(k) - offset + + propor = drr/dzsno(fc,k) + zwice = propor*swice(fc,k) + zwliq = propor*swliq(fc,k) + zmbc_phi = propor*mbc_phi(fc,k) + zmbc_pho = propor*mbc_pho(fc,k) + zmoc_phi = propor*moc_phi(fc,k) + zmoc_pho = propor*moc_pho(fc,k) + zmdst1 = propor*mdst1(fc,k) + zmdst2 = propor*mdst2(fc,k) + zmdst3 = propor*mdst3(fc,k) + zmdst4 = propor*mdst4(fc,k) + + propor = (dzmax_u(k)+offset)/dzsno(fc,k) + swice(fc,k) = propor*swice(fc,k) + swliq(fc,k) = propor*swliq(fc,k) + mbc_phi(fc,k) = propor*mbc_phi(fc,k) + mbc_pho(fc,k) = propor*mbc_pho(fc,k) + moc_phi(fc,k) = propor*moc_phi(fc,k) + moc_pho(fc,k) = propor*moc_pho(fc,k) + mdst1(fc,k) = propor*mdst1(fc,k) + mdst2(fc,k) = propor*mdst2(fc,k) + mdst3(fc,k) = propor*mdst3(fc,k) + mdst4(fc,k) = propor*mdst4(fc,k) ! Set depth layer k to maximum allowed value - dzsno(c,k) = dzmax_u(k) + offset + dzsno(fc,k) = dzmax_u(k) + offset - mbc_phi(c,k+1) = mbc_phi(c,k+1)+zmbc_phi ! (combo) - mbc_pho(c,k+1) = mbc_pho(c,k+1)+zmbc_pho ! (combo) - moc_phi(c,k+1) = moc_phi(c,k+1)+zmoc_phi ! (combo) - moc_pho(c,k+1) = moc_pho(c,k+1)+zmoc_pho ! (combo) - mdst1(c,k+1) = mdst1(c,k+1)+zmdst1 ! (combo) - mdst2(c,k+1) = mdst2(c,k+1)+zmdst2 ! (combo) - mdst3(c,k+1) = mdst3(c,k+1)+zmdst3 ! (combo) - mdst4(c,k+1) = mdst4(c,k+1)+zmdst4 ! (combo) + mbc_phi(fc,k+1) = mbc_phi(fc,k+1)+zmbc_phi ! (combo) + mbc_pho(fc,k+1) = mbc_pho(fc,k+1)+zmbc_pho ! (combo) + moc_phi(fc,k+1) = moc_phi(fc,k+1)+zmoc_phi ! (combo) + moc_pho(fc,k+1) = moc_pho(fc,k+1)+zmoc_pho ! (combo) + mdst1(fc,k+1) = mdst1(fc,k+1)+zmdst1 ! (combo) + mdst2(fc,k+1) = mdst2(fc,k+1)+zmdst2 ! (combo) + mdst3(fc,k+1) = mdst3(fc,k+1)+zmdst3 ! (combo) + mdst4(fc,k+1) = mdst4(fc,k+1)+zmdst4 ! (combo) ! Mass-weighted combination of radius - rds(c,k+1) = MassWeightedSnowRadius( rds(c,k), rds(c,k+1), & - (swliq(c,k+1)+swice(c,k+1)), (zwliq+zwice) ) + rds(fc,k+1) = MassWeightedSnowRadius( rds(fc,k), rds(fc,k+1), & + (swliq(fc,k+1)+swice(fc,k+1)), (zwliq+zwice) ) - call Combo (dzsno(c,k+1), swliq(c,k+1), swice(c,k+1), tsno(c,k+1), drr, & - zwliq, zwice, tsno(c,k)) + call Combo (dzsno(fc,k+1), swliq(fc,k+1), swice(fc,k+1), tsno(fc,k+1), drr, & + zwliq, zwice, tsno(fc,k)) end if end if k = k+1 @@ -2069,27 +2302,28 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & end do loop_snowcolumns + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1,0 do fc = 1, num_snowc c = filter_snowc(fc) if (j >= snl(c)+1) then if (is_lake) then - dz(c,j) = dzsno(c,j-snl(c)) + dz(c,j) = dzsno(fc,j-snl(c)) else - dz(c,j) = dzsno(c,j-snl(c))/frac_sno(c) + dz(c,j) = dzsno(fc,j-snl(c))/frac_sno(c) end if - h2osoi_ice(c,j) = swice(c,j-snl(c)) - h2osoi_liq(c,j) = swliq(c,j-snl(c)) - t_soisno(c,j) = tsno(c,j-snl(c)) - mss_bcphi(c,j) = mbc_phi(c,j-snl(c)) - mss_bcpho(c,j) = mbc_pho(c,j-snl(c)) - mss_ocphi(c,j) = moc_phi(c,j-snl(c)) - mss_ocpho(c,j) = moc_pho(c,j-snl(c)) - mss_dst1(c,j) = mdst1(c,j-snl(c)) - mss_dst2(c,j) = mdst2(c,j-snl(c)) - mss_dst3(c,j) = mdst3(c,j-snl(c)) - mss_dst4(c,j) = mdst4(c,j-snl(c)) - snw_rds(c,j) = rds(c,j-snl(c)) + h2osoi_ice(c,j) = swice(fc,j-snl(c)) + h2osoi_liq(c,j) = swliq(fc,j-snl(c)) + t_soisno(c,j) = tsno(fc,j-snl(c)) + mss_bcphi(c,j) = mbc_phi(fc,j-snl(c)) + mss_bcpho(c,j) = mbc_pho(fc,j-snl(c)) + mss_ocphi(c,j) = moc_phi(fc,j-snl(c)) + mss_ocpho(c,j) = moc_pho(fc,j-snl(c)) + mss_dst1(c,j) = mdst1(fc,j-snl(c)) + mss_dst2(c,j) = mdst2(fc,j-snl(c)) + mss_dst3(c,j) = mdst3(fc,j-snl(c)) + mss_dst4(c,j) = mdst4(fc,j-snl(c)) + snw_rds(c,j) = rds(fc,j-snl(c)) end if end do end do @@ -2101,17 +2335,17 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & c = filter_snowc(fc) if (j >= snl(c)+1) then - dztot(c) = dztot(c) - dz(c,j) - snwicetot(c) = snwicetot(c) - h2osoi_ice(c,j) - snwliqtot(c) = snwliqtot(c) - h2osoi_liq(c,j) + dztot(fc) = dztot(fc) - dz(c,j) + snwicetot(fc) = snwicetot(fc) - h2osoi_ice(c,j) + snwliqtot(fc) = snwliqtot(fc) - h2osoi_liq(c,j) end if if (j == 0) then - if ( abs(dztot(c)) > 1.e-10_r8 .or. abs(snwicetot(c)) > 1.e-7_r8 .or. & - abs(snwliqtot(c)) > 1.e-7_r8 ) then + if ( abs(dztot(fc)) > 1.e-10_r8 .or. abs(snwicetot(fc)) > 1.e-7_r8 .or. & + abs(snwliqtot(fc)) > 1.e-7_r8 ) then #ifndef _OPENACC write(iulog,*)'Inconsistency in SnowDivision_Lake! c, remainders', & - 'dztot, snwicetot, snwliqtot = ',c,dztot(c),snwicetot(c),snwliqtot(c) + 'dztot, snwicetot, snwliqtot = ',c,dztot(fc),snwicetot(fc),snwliqtot(fc) call endrun(decomp_index=c, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) #endif end if @@ -2120,6 +2354,7 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & end do end if + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 0, -nlevsno+1, -1 do fc = 1, num_snowc c = filter_snowc(fc) @@ -2130,6 +2365,25 @@ subroutine DivideExtraSnowLayers(bounds, num_snowc, filter_snowc, & end do end do + !$acc exit data delete(& + !$acc dzsno(:,:), & + !$acc swice(:,:), & + !$acc swliq(:,:), & + !$acc tsno(:,:), & + !$acc mbc_phi(:,:), & + !$acc mbc_pho(:,:), & + !$acc moc_phi(:,:), & + !$acc moc_pho(:,:), & + !$acc mdst1(:,:), & + !$acc mdst2(:,:), & + !$acc mdst3(:,:), & + !$acc mdst4(:,:), & + !$acc rds(:,:), & + !$acc dztot(:), & + !$acc snwicetot(:), & + !$acc snwliqtot(:), & + !$acc msno) + end associate end subroutine DivideExtraSnowLayers @@ -2352,7 +2606,7 @@ subroutine SnowCapping(bounds, num_nolakec, filter_initc, num_snowc, filter_snow end subroutine SnowCapping !----------------------------------------------------------------------- - subroutine NewSnowBulkDensity(bounds, num_c, filter_c, top_as_inst, bifall) + subroutine NewSnowBulkDensity(bounds, num_c, filter_c, top_as, bifall) ! (subroutine from CLMv5) ! !DESCRIPTION: ! Compute the bulk density of any newly-fallen snow. @@ -2367,7 +2621,7 @@ subroutine NewSnowBulkDensity(bounds, num_c, filter_c, top_as_inst, bifall) type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_c ! number of columns in filterc integer , intent(in) :: filter_c(:) ! column-level filter to operate on - type(topounit_atmospheric_state) , intent(in) :: top_as_inst + type(topounit_atmospheric_state) , intent(in) :: top_as real(r8) , intent(inout) :: bifall(bounds%begc:) ! bulk density of newly fallen dry snow [kg/m3] ! ! !LOCAL VARIABLES: @@ -2377,8 +2631,8 @@ subroutine NewSnowBulkDensity(bounds, num_c, filter_c, top_as_inst, bifall) character(len=*), parameter :: subname = 'NewSnowBulkDensity' !----------------------------------------------------------------------- - associate(forc_t => top_as_inst%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) - forc_wind => top_as_inst%windbot & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) + associate(forc_t => top_as%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (Kelvin) + forc_wind => top_as%windbot & ! Input: [real(r8) (:) ] atmospheric wind speed (m/s) ) do fc = 1, num_c @@ -2436,6 +2690,7 @@ subroutine WindDriftCompaction(bi, forc_wind, dz, & ! !USES: ! ! !ARGUMENTS: + !$acc routine seq 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] @@ -2543,7 +2798,7 @@ function MassWeightedSnowRadius( rds1, rds2, swtot, zwtot ) result(mass_weighted ! (from CLMv5) ! !DESCRIPTION: ! Calculate the mass weighted snow radius when two layers are combined - ! + !$acc routine seq ! !USES: use AerosolMod , only : snw_rds_min use SnowSnicarMod, only : snw_rds_max @@ -2565,7 +2820,7 @@ function MassWeightedSnowRadius( rds1, rds2, swtot, zwtot ) result(mass_weighted end function MassWeightedSnowRadius !----------------------------------------------------------------------- - subroutine BuildSnowFilter(bounds, num_nolakec, filter_nolakec, & + subroutine BuildSnowFilter(num_nolakec, filter_nolakec, & num_snowc, filter_snowc, num_nosnowc, filter_nosnowc) ! ! !DESCRIPTION: @@ -2574,8 +2829,6 @@ subroutine BuildSnowFilter(bounds, num_nolakec, filter_nolakec, & ! !USES: ! ! !ARGUMENTS: - !$acc routine seq - type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points integer , intent(out) :: num_snowc ! number of column snow points in column filter @@ -2584,23 +2837,40 @@ subroutine BuildSnowFilter(bounds, num_nolakec, filter_nolakec, & integer , intent(out) :: filter_nosnowc(:) ! column filter for non-snow points ! ! !LOCAL VARIABLES: - integer :: fc, c + integer :: fc, c, fsnow, fnosnow + integer :: snow_tot, nosnow_tot !----------------------------------------------------------------------- ! Build snow/no-snow filters for other subroutines + !$acc enter data create(fsnow, fnosnow) - num_snowc = 0 - num_nosnowc = 0 + snow_tot = 0 + nosnow_tot = 0 + !$acc parallel loop independent gang vector present(filter_snowc(:),filter_nosnowc(:),filter_nolakec(:)) & + !$acc private(fsnow,fnosnow) copy(snow_tot, nosnow_tot) do fc = 1, num_nolakec + c = filter_nolakec(fc) if (col_pp%snl(c) < 0) then - num_snowc = num_snowc + 1 - filter_snowc(num_snowc) = c + !$acc atomic capture + snow_tot = snow_tot + 1 + fsnow = snow_tot + !$acc end atomic + filter_snowc(fsnow) = c else - num_nosnowc = num_nosnowc + 1 - filter_nosnowc(num_nosnowc) = c + !$acc atomic capture + nosnow_tot = nosnow_tot + 1 + fnosnow = nosnow_tot + !$acc end atomic + filter_nosnowc(fnosnow) = c end if end do + + num_snowc = snow_tot + num_nosnowc = nosnow_tot + + !$acc exit data delete(fsnow, fnosnow) + end subroutine BuildSnowFilter end module SnowHydrologyMod diff --git a/components/elm/src/biogeophys/SnowSnicarMod.F90 b/components/elm/src/biogeophys/SnowSnicarMod.F90 index 157f540c8256..afaebabf1c00 100644 --- a/components/elm/src/biogeophys/SnowSnicarMod.F90 +++ b/components/elm/src/biogeophys/SnowSnicarMod.F90 @@ -75,8 +75,6 @@ module SnowSnicarMod !$acc declare copyin(idx_bcint_icerds_max) #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] @@ -104,8 +102,7 @@ module SnowSnicarMod !$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 - !$acc declare copyin(flg_snoage_scl) + logical, parameter :: 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 !$acc declare copyin(xdrdt) ! snow and aerosol Mie parameters: @@ -190,8 +187,6 @@ module SnowSnicarMod !$acc declare create(ss_alb_bc2 ) !$acc declare create(asm_prm_bc2 ) !$acc declare create(ext_cff_mss_bc2) - - #endif ! ! hydrophiliic BC @@ -728,7 +723,7 @@ subroutine SNICAR_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & enddo endif -!H. Wang + !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) @@ -738,7 +733,7 @@ subroutine SNICAR_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & ! 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 + !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) @@ -1394,8 +1389,10 @@ subroutine SnowAge_grain(bounds, & if ( abs(dr_fresh) < 1.0e-8_r8 ) then dr_fresh = 0.0_r8 else if ( dr_fresh < 0.0_r8 ) then +#ifndef _OPENACC write(iulog,*) "dr_fresh = ", dr_fresh call endrun( "dr_fresh < 0" ) +#endif end if dr = (bst_drdt0*(bst_tau/(dr_fresh+bst_tau))**(1._r8/bst_kappa)) * (dtime/3600._r8) @@ -1808,7 +1805,6 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & ! The inputs and outputs are the same to subroutine SNICAR_RT ! ! !USES: - !$acc routine seq use elm_varpar , only : nlevsno, numrad use elm_time_manager , only : get_nstep use shr_const_mod , only : SHR_CONST_PI @@ -2307,6 +2303,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & ! Error check for snow grain size: +#ifndef _OPENACC 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." @@ -2318,7 +2315,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & call endrun(decomp_index=c_idx, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) endif enddo - +#endif ! Incident flux weighting parameters ! - sum of all VIS bands must equal 1 ! - sum of all NIR bands must equal 1 @@ -2933,7 +2930,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & do i=snl_top,snl_btm,1 F_abs(i) = dftmp(i)-dftmp(i+1) flx_abs_lcl(i,bnd_idx) = F_abs(i) - +#ifndef _OPENACC ! ERROR check: negative absorption if (flx_abs_lcl(i,bnd_idx) < -0.00001) then write (iulog,"(a,e13.6,a,i6,a,i6)") "SNICAR ERROR: negative absoption : ", flx_abs_lcl(i,bnd_idx), & @@ -2949,6 +2946,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & write(iulog,*) "SNICAR_AD STATS: dust4(0)= ", mss_cnc_aer_lcl(0,6) call endrun(decomp_index=c_idx, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) endif +#endif enddo ! absobed flux by the underlying ground @@ -2987,6 +2985,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & ! 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) +#ifndef _OPENACC if (abs(energy_sum) > 0.00001_r8) then write (iulog,"(a,e13.6,a,i6,a,i6)") "SNICAR ERROR: Energy conservation error of : ", energy_sum, & " at timestep: ", nstep, " at column: ", c_idx @@ -3000,7 +2999,6 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & write(iulog,*) "albedo", albedo call endrun(decomp_index=c_idx, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) endif - albout_lcl(bnd_idx) = albedo ! Check that albedo is less than 1 if (albout_lcl(bnd_idx) > 1.0) then @@ -3032,6 +3030,7 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & call endrun(decomp_index=c_idx, elmlevel=namec, msg=errmsg(__FILE__, __LINE__)) endif +#endif enddo ! loop over wvl bands @@ -3082,6 +3081,6 @@ subroutine SNICAR_AD_RT (flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & end associate end subroutine SNICAR_AD_RT - + end module SnowSnicarMod diff --git a/components/elm/src/biogeophys/SoilFluxesMod.F90 b/components/elm/src/biogeophys/SoilFluxesMod.F90 index d0043f4d1d76..eef4ee8371ec 100644 --- a/components/elm/src/biogeophys/SoilFluxesMod.F90 +++ b/components/elm/src/biogeophys/SoilFluxesMod.F90 @@ -167,12 +167,12 @@ subroutine SoilFluxes (bounds, num_urbanl, filter_urbanl, & deg2rad = SHR_CONST_PI/180._r8 - dtime = dtime_mod + dtime = dtime_mod call t_startf('bgp2_loop_1') do fc = 1,num_nolakec c = filter_nolakec(fc) j = col_pp%snl(c)+1 - + ! Calculate difference in soil temperature from last time step, for ! flux corrections @@ -298,6 +298,11 @@ subroutine SoilFluxes (bounds, num_urbanl, filter_urbanl, & - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) endif + eflx_soil_grnd(p) = ((1._r8- frac_sno_eff(c))*sabg_soil(p) + frac_sno_eff(c)*sabg_snow(p)) + dlrad(p) & + + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & + - emg(c)*sb*lw_grnd - emg(c)*sb*t_grnd0(c)**3*(4._r8*tinc(c)) & + - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) + if (veg_pp%is_on_soil_col(p) .or. veg_pp%is_on_crop_col(p)) then eflx_soil_grnd_r(p) = eflx_soil_grnd(p) end if @@ -430,9 +435,9 @@ subroutine SoilFluxes (bounds, num_urbanl, filter_urbanl, & j = col_pp%snl(c)+1 if (.not. lun_pp%urbpoi(l)) then - lw_grnd=(frac_sno_eff(c)*tssbef(c,col_pp%snl(c)+1)**4 & - +(1._r8-frac_sno_eff(c)-frac_h2osfc(c))*tssbef(c,1)**4 & - +frac_h2osfc(c)*t_h2osfc_bef(c)**4) + lw_grnd=(frac_sno_eff(c)*tssbef(c,col_pp%snl(c)+1)**4._r8 & + +(1._r8-frac_sno_eff(c)-frac_h2osfc(c))*tssbef(c,1)**4._r8 & + +frac_h2osfc(c)*t_h2osfc_bef(c)**4._r8) if (use_finetop_rad) then slope_rad = slope_deg(g) * deg2rad diff --git a/components/elm/src/biogeophys/SoilHydrologyMod.F90 b/components/elm/src/biogeophys/SoilHydrologyMod.F90 index 51f1dd28711f..4a157d9bf529 100644 --- a/components/elm/src/biogeophys/SoilHydrologyMod.F90 +++ b/components/elm/src/biogeophys/SoilHydrologyMod.F90 @@ -11,7 +11,6 @@ module SoilHydrologyMod use elm_varctl , only : use_lnd_rof_two_way, lnd_rof_coupling_nstep use elm_varctl , only : use_modified_infil, use_ocn_lnd_one_way use elm_varcon , only : e_ice, denh2o, denice, rpi - use EnergyFluxType , only : energyflux_type use SoilHydrologyType , only : soilhydrology_type use SoilStateType , only : soilstate_type use WaterfluxType , only : waterflux_type @@ -48,7 +47,6 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & ! Calculate surface runoff ! ! !USES: - !$acc routine seq use elm_varcon , only : denice, denh2o, wimp, pondmx_urban, frac_from_uphill use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use column_varcon , only : icol_road_imperv, icol_road_perv @@ -70,9 +68,9 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & ! !LOCAL VARIABLES: integer :: c,j,fc,g,l,t,i !indices integer :: nlevbed !# levels to bedrock - real(r8) :: xs(bounds%begc:bounds%endc) !excess soil water above urban ponding limit - real(r8) :: vol_ice(bounds%begc:bounds%endc,1:nlevgrnd) !partial volume of ice lens in layer - real(r8) :: fff(bounds%begc:bounds%endc) !decay factor (m-1) + real(r8) :: xs(1:num_urbanc) !excess soil water above urban ponding limit + real(r8) :: vol_ice(1:num_hydrologyc,1:nlevgrnd) !partial volume of ice lens in layer + real(r8) :: fff(1:num_hydrologyc) !decay factor (m-1) real(r8) :: s1 !variable to calculate qinmax real(r8) :: su !variable to calculate qinmax real(r8) :: v !variable to calculate qinmax @@ -125,22 +123,28 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & max_infil => soilhydrology_vars%max_infil_col , & ! Output: [real(r8) (:) ] maximum infiltration capacity in VIC (mm) i_0 => soilhydrology_vars%i_0_col & ! Output: [real(r8) (:) ] column average soil moisture in top VIC layers (mm) ) + !$acc enter data create(& + !$acc xs(:), & + !$acc vol_ice(:,:), & + !$acc fff(:) ) - ! Get time step + !NOTE: Need to separate out the vichydro only arrays + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop vector independent do j = 1,nlevbed ! Porosity of soil, partial volume of ice and liquid, fraction of ice in each layer, ! fractional impermeability - vol_ice(c,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) + vol_ice(fc,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) if (origflag == 1) then icefrac(c,j) = min(1._r8,h2osoi_ice(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j))) else - icefrac(c,j) = min(1._r8,vol_ice(c,j)/watsat(c,j)) + icefrac(c,j) = min(1._r8,vol_ice(fc,j)/watsat(c,j)) endif fracice(c,j) = max(0._r8,exp(-3._r8*(1._r8-icefrac(c,j)))- exp(-3._r8))/(1.0_r8-exp(-3._r8)) @@ -148,60 +152,56 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & end do ! Saturated fraction - + !NOTE : assuming use_vichydro is .false. + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) g = col_pp%gridcell(c) - fff(c) = fover(g) + fff(fc) = fover(g) if (zengdecker_2009_with_var_soil_thick) then nlevbed = nlev2bed(c) - fff(c) = 0.5_r8 * col_pp%zi(c,nlevsoi) / min(col_pp%zi(c,nlevbed), col_pp%zi(c,nlevsoi)) - end if - if (use_vichydro) then - top_moist(c) = 0._r8 - top_ice(c) = 0._r8 - top_max_moist(c) = 0._r8 - do j = 1, nlayer - 1 - top_ice(c) = top_ice(c) + ice(c,j) - top_moist(c) = top_moist(c) + moist(c,j) + ice(c,j) - top_max_moist(c) = top_max_moist(c) + max_moist(c,j) - end do - if(top_moist(c)> top_max_moist(c)) top_moist(c)= top_max_moist(c) - top_ice(c) = max(0._r8,top_ice(c)) - max_infil(c) = (1._r8+b_infil(c)) * top_max_moist(c) - ex(c) = b_infil(c) / (1._r8 + b_infil(c)) - A(c) = 1._r8 - (1._r8 - top_moist(c) / top_max_moist(c))**ex(c) - i_0(c) = max_infil(c) * (1._r8 - (1._r8 - A(c))**(1._r8/b_infil(c))) - fsat(c) = A(c) !for output - else - fsat(c) = wtfact(c) * exp(-0.5_r8*fff(c)*zwt(c)) + fff(fc) = 0.5_r8 * col_pp%zi(c,nlevsoi) / min(col_pp%zi(c,nlevbed), col_pp%zi(c,nlevsoi)) end if + !if (use_vichydro) then + ! top_moist(c) = 0._r8 + ! top_ice(c) = 0._r8 + ! top_max_moist(c) = 0._r8 + ! do j = 1, nlayer - 1 + ! top_ice(c) = top_ice(c) + ice(c,j) + ! top_moist(c) = top_moist(c) + moist(c,j) + ice(c,j) + ! top_max_moist(c) = top_max_moist(c) + max_moist(c,j) + ! end do + ! if(top_moist(c)> top_max_moist(c)) top_moist(c)= top_max_moist(c) + ! top_ice(c) = max(0._r8,top_ice(c)) + ! max_infil(c) = (1._r8+b_infil(c)) * top_max_moist(c) + ! ex(c) = b_infil(c) / (1._r8 + b_infil(c)) + ! A(c) = 1._r8 - (1._r8 - top_moist(c) / top_max_moist(c))**ex(c) + ! i_0(c) = max_infil(c) * (1._r8 - (1._r8 - A(c))**(1._r8/b_infil(c))) + ! fsat(c) = A(c) !for output + !else + fsat(c) = wtfact(c) * exp(-0.5_r8*fff(fc)*zwt(c)) + !end if ! use perched water table to determine fsat (if present) if ( frost_table(c) > zwt(c)) then - if (use_vichydro) then - fsat(c) = A(c) - else - fsat(c) = wtfact(c) * exp(-0.5_r8*fff(c)*zwt(c)) - end if + !if (use_vichydro) then + ! fsat(c) = A(c) + !else + fsat(c) = wtfact(c) * exp(-0.5_r8*fff(fc)*zwt(c)) + !end if else if ( frost_table(c) > zwt_perched(c)) then - fsat(c) = wtfact(c) * exp(-0.5_r8*fff(c)*zwt_perched(c))!*( frost_table(c) - zwt_perched(c))/4.0 + fsat(c) = wtfact(c) * exp(-0.5_r8*fff(fc)*zwt_perched(c))!*( frost_table(c) - zwt_perched(c))/4.0 endif endif if (origflag == 1) then - if (use_vichydro) then -#ifndef _OPENACC - call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(__FILE__, __LINE__)) -#endif - else fcov(c) = (1._r8 - fracice(c,1)) * fsat(c) + fracice(c,1) - end if else fcov(c) = fsat(c) endif end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) l = col_pp%landunit(c) @@ -222,6 +222,7 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & ! Determine water in excess of ponding limit for urban roof and impervious road. ! Excess goes to surface runoff. No surface runoff for sunwall and shadewall. + !$acc parallel loop independent gang vector default(present) do fc = 1, num_urbanc c = filter_urbanc(fc) if (col_pp%itype(c) == icol_roof .or. col_pp%itype(c) == icol_road_imperv) then @@ -230,26 +231,26 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & if (snl(c) < 0) then qflx_surf(c) = max(0._r8,qflx_top_soil(c)) else - xs(c) = max(0._r8, & + xs(fc) = max(0._r8, & h2osoi_liq(c,1)/dtime + qflx_top_soil(c) - qflx_evap_grnd(c) - & pondmx_urban/dtime) - if (xs(c) > 0.) then + if (xs(fc) > 0._r8) then h2osoi_liq(c,1) = pondmx_urban else h2osoi_liq(c,1) = max(0._r8,h2osoi_liq(c,1)+ & (qflx_top_soil(c)-qflx_evap_grnd(c))*dtime) end if - qflx_surf(c) = xs(c) + qflx_surf(c) = xs(fc) end if else if (col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall) then qflx_surf(c) = 0._r8 end if ! send flood water flux to runoff for all urban columns qflx_surf(c) = qflx_surf(c) + qflx_floodc(c) - end do ! remove stormflow and snow on h2osfc from qflx_top_soil + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) t = col_pp%topounit(c) @@ -284,6 +285,10 @@ subroutine SurfaceRunoff (bounds, num_hydrologyc, filter_hydrologyc, & qflx_top_soil(c) = qflx_top_soil(c) + qflx_from_uphill(c) end do endif + !$acc exit data delete(& + !$acc xs(:), & + !$acc vol_ice(:,:), & + !$acc fff(:) ) end associate @@ -291,13 +296,12 @@ end subroutine SurfaceRunoff !----------------------------------------------------------------------- subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filter_urbanc, & - atm2lnd_vars, ocn2lnd_vars, lnd2atm_vars, energyflux_vars, soilhydrology_vars, soilstate_vars, dtime) + soilhydrology_vars, ocn2lnd_vars, soilstate_vars, dtime) ! ! !DESCRIPTION: ! Calculate infiltration into surface soil layer (minus the evaporation) ! ! !USES: - !$acc routine seq use shr_const_mod , only : shr_const_pi use elm_varpar , only : nlayer, nlayert use elm_varpar , only : nlevsoi, nlevgrnd @@ -317,10 +321,7 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f integer , intent(in) :: filter_hydrologyc(:) ! column filter for soil points integer , intent(in) :: num_urbanc ! number of column urban points in column filter integer , intent(in) :: filter_urbanc(:) ! column filter for urban points - type(atm2lnd_type) , intent(in) :: atm2lnd_vars ! land river two way coupling type(ocn2lnd_type) , intent(in) :: ocn2lnd_vars ! ocean land one way coupling - type(lnd2atm_type) , intent(in) :: lnd2atm_vars - type(energyflux_type) , intent(in) :: energyflux_vars type(soilhydrology_type) , intent(inout) :: soilhydrology_vars type(soilstate_type) , intent(inout) :: soilstate_vars real(r8), intent(in) :: dtime @@ -330,13 +331,13 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f integer :: nlevbed !# levels to bedrock real(r8) :: s1,su,v ! variable to calculate qinmax real(r8) :: qinmax ! maximum infiltration capacity (mm/s) - real(r8) :: vol_ice(bounds%begc:bounds%endc,1:nlevgrnd) ! partial volume of ice lens in layer + real(r8) :: vol_ice(1:num_hydrologyc,1:nlevgrnd) ! partial volume of ice lens in layer real(r8) :: alpha_evap(bounds%begc:bounds%endc) ! fraction of total evap from h2osfc - real(r8) :: qflx_evap(bounds%begc:bounds%endc) ! local evaporation array - real(r8) :: qflx_h2osfc_drain(bounds%begc:bounds%endc) ! bottom drainage from h2osfc - real(r8) :: qflx_in_h2osfc(bounds%begc:bounds%endc) ! surface input to h2osfc - real(r8) :: qflx_in_soil(bounds%begc:bounds%endc) ! surface input to soil - real(r8) :: qflx_infl_excess(bounds%begc:bounds%endc) ! infiltration excess runoff -> h2osfc + real(r8) :: qflx_evap(1:num_hydrologyc) ! local evaporation array + real(r8) :: qflx_h2osfc_drain(1:num_hydrologyc) ! bottom drainage from h2osfc + real(r8) :: qflx_in_h2osfc(1:num_hydrologyc) ! surface input to h2osfc + real(r8) :: qflx_in_soil(1:num_hydrologyc) ! surface input to soil + real(r8) :: qflx_infl_excess(1:num_hydrologyc) ! infiltration excess runoff -> h2osfc real(r8) :: frac_infclust ! fraction of submerged area that is connected real(r8) :: fsno ! copy of frac_sno real(r8) :: k_wet ! linear reservoir coefficient for h2osfc @@ -427,20 +428,34 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f pc_grid => soilhydrology_vars%pc , & ! Input: [real(r8) (:) ] threshold for outflow from surface water storage icefrac => soilhydrology_vars%icefrac_col & ! Output: [real(r8) (:,:) ] fraction of ice ) - + !$acc enter data create(& + !$acc vol_ice(:,:), & + !$acc alpha_evap(:), & + !$acc qflx_evap(:), & + !$acc qflx_h2osfc_drain(:), & + !$acc qflx_in_h2osfc(:), & + !$acc qflx_in_soil(:), & + !$acc qflx_infl_excess(:), & + !$acc top_moist(:), & + !$acc top_max_moist(:), & + !$acc top_ice(:)) ! Infiltration into surface soil layer (minus the evaporation) + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop vector independent do j = 1,nlevbed ! Porosity of soil, partial volume of ice and liquid - vol_ice(c,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) - eff_porosity(c,j) = max(0.01_r8,watsat(c,j)-vol_ice(c,j)) - icefrac(c,j) = min(1._r8,vol_ice(c,j)/watsat(c,j)) + vol_ice(fc,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) + eff_porosity(c,j) = max(0.01_r8,watsat(c,j)-vol_ice(fc,j)) + icefrac(c,j) = min(1._r8,vol_ice(fc,j)/watsat(c,j)) end do end do + !NOTE : Assuming use_vichydro is .false. + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) g = cgridcell(c) @@ -454,10 +469,10 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f if (snl(c) >= 0) then fsno=0._r8 ! if no snow layers, sublimation is removed from h2osoi_ice in drainage - qflx_evap(c)=qflx_evap_grnd(c) + qflx_evap(fc)=qflx_evap_grnd(c) else fsno=frac_sno(c) - qflx_evap(c)=qflx_ev_soil(c) + qflx_evap(fc)=qflx_ev_soil(c) endif !0. partition grid-level floodplain/coastal inundation volume and fraction to each column @@ -480,19 +495,19 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f endif !1. partition surface inputs between soil and h2osfc - qflx_in_soil(c) = (1._r8 - frac_h2osfc(c)) * (qflx_top_soil(c) - qflx_surf(c)) - qflx_in_h2osfc(c) = frac_h2osfc(c) * (qflx_top_soil(c) - qflx_surf(c)) + qflx_in_soil(fc) = (1._r8 - frac_h2osfc(c)) * (qflx_top_soil(c) - qflx_surf(c)) + qflx_in_h2osfc(fc) = frac_h2osfc(c) * (qflx_top_soil(c) - qflx_surf(c)) qflx_gross_infl_soil(c) = (1._r8 - frac_h2osfc(c)) * (qflx_top_soil(c) - qflx_surf(c)) !2. remove evaporation (snow treated in SnowHydrology) - qflx_in_soil(c) = qflx_in_soil(c) - (1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(c) - qflx_in_h2osfc(c) = qflx_in_h2osfc(c) - frac_h2osfc(c) * qflx_ev_h2osfc(c) + qflx_in_soil(fc) = qflx_in_soil(fc) - (1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(fc) + qflx_in_h2osfc(fc) = qflx_in_h2osfc(fc) - frac_h2osfc(c) * qflx_ev_h2osfc(c) - if (qflx_evap(c)>0._r8) then - qflx_gross_evap_soil(c) = (1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(c) + if (qflx_evap(fc)>0._r8) then + qflx_gross_evap_soil(c) = (1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(fc) else qflx_gross_evap_soil(c) = 0._r8 - qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c)-(1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(c) + qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c)-(1.0_r8 - fsno - frac_h2osfc(c))*qflx_evap(fc) endif !3. determine maximum infiltration rate @@ -506,19 +521,19 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f top_max_moist(c) = top_max_moist(c) + max_moist(c,j) end do top_icefrac = min(1._r8,top_ice(c)/top_max_moist(c)) - if(qflx_in_soil(c) <= 0._r8) then + if(qflx_in_soil(fc) <= 0._r8) then rsurf_vic = 0._r8 else if(max_infil(c) <= 0._r8) then - rsurf_vic = qflx_in_soil(c) - else if((i_0(c) + qflx_in_soil(c)*dtime) > max_infil(c)) then !(Eq.(3a) Wood et al. 1992) - rsurf_vic = (qflx_in_soil(c)*dtime - top_max_moist(c) + top_moist(c))/dtime + rsurf_vic = qflx_in_soil(fc) + else if((i_0(c) + qflx_in_soil(fc)*dtime) > max_infil(c)) then !(Eq.(3a) Wood et al. 1992) + rsurf_vic = (qflx_in_soil(fc)*dtime - top_max_moist(c) + top_moist(c))/dtime else !(Eq.(3b) Wood et al. 1992) - basis = 1._r8 - (i_0(c) + qflx_in_soil(c)*dtime)/max_infil(c) - rsurf_vic = (qflx_in_soil(c)*dtime - top_max_moist(c) + top_moist(c) & + basis = 1._r8 - (i_0(c) + qflx_in_soil(fc)*dtime)/max_infil(c) + rsurf_vic = (qflx_in_soil(fc)*dtime - top_max_moist(c) + top_moist(c) & + top_max_moist(c) * basis**(1._r8 + b_infil(c)))/dtime end if - rsurf_vic = min(qflx_in_soil(c), rsurf_vic) - qinmax = (1._r8 - fsat(c)) * 10._r8**(-e_ice*top_icefrac)*(qflx_in_soil(c) - rsurf_vic) + rsurf_vic = min(qflx_in_soil(fc), rsurf_vic) + qinmax = (1._r8 - fsat(c)) * 10._r8**(-e_ice*top_icefrac)*(qflx_in_soil(fc) - rsurf_vic) else if ( use_modified_infil ) then qinmax=minval(10._r8**(-e_ice*(icefrac(c,1:3)))*hksat(c,1:3)) @@ -530,26 +545,26 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f if ( use_modified_infil ) then ! Assume frac_h2osfc occurs on fsat if ( frac_h2osfc(c) >= fsat(c) ) then - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - frac_h2osfc(c))*qinmax) + qflx_infl_excess(fc) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - frac_h2osfc(c))*qinmax) else - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - fsat(c))*qinmax) + qflx_infl_excess(fc) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - fsat(c))*qinmax) end if else - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - frac_h2osfc(c))*qinmax) + qflx_infl_excess(fc) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - frac_h2osfc(c))*qinmax) end if if (use_lnd_rof_two_way) then - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - frac_h2osfc(c) - frac_h2orof(c))*qinmax) + qflx_infl_excess(c) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - frac_h2osfc(c) - frac_h2orof(c))*qinmax) elseif (use_ocn_lnd_one_way) then - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - frac_h2osfc(c) - frac_h2oocn(c))*qinmax) + qflx_infl_excess(c) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - frac_h2osfc(c) - frac_h2oocn(c))*qinmax) else - qflx_infl_excess(c) = max(0._r8,qflx_in_soil(c) - (1.0_r8 - frac_h2osfc(c))*qinmax) + qflx_infl_excess(fc) = max(0._r8,qflx_in_soil(fc) - (1.0_r8 - frac_h2osfc(c))*qinmax) endif !4. soil infiltration and h2osfc "run-on" - qflx_infl(c) = qflx_in_soil(c) - qflx_infl_excess(c) - qflx_in_h2osfc(c) = qflx_in_h2osfc(c) + qflx_infl_excess(c) - qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c)- qflx_infl_excess(c) + qflx_infl(c) = qflx_in_soil(fc) - qflx_infl_excess(fc) + qflx_in_h2osfc(fc) = qflx_in_h2osfc(fc) + qflx_infl_excess(fc) + qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c)- qflx_infl_excess(fc) !5. surface runoff from h2osfc if (h2osfcflag==1) then @@ -612,43 +627,43 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f if(h2osfcflag==0) then qflx_h2osfc_surf(c)= 0._r8 ! shift infiltration excess from h2osfc input to surface runoff - qflx_in_h2osfc(c) = qflx_in_h2osfc(c) - qflx_infl_excess(c) - qflx_surf(c)= qflx_surf(c) + qflx_infl_excess(c) - qflx_infl_excess(c) = 0._r8 + qflx_in_h2osfc(fc) = qflx_in_h2osfc(fc) - qflx_infl_excess(fc) + qflx_surf(c)= qflx_surf(c) + qflx_infl_excess(fc) + qflx_infl_excess(fc) = 0._r8 endif - qflx_in_h2osfc(c) = qflx_in_h2osfc(c) - qflx_h2osfc_surf(c) + qflx_in_h2osfc(fc) = qflx_in_h2osfc(fc) - qflx_h2osfc_surf(c) !6. update h2osfc prior to calculating bottom drainage from h2osfc - h2osfc(c) = h2osfc(c) + qflx_in_h2osfc(c) * dtime + h2osfc(c) = h2osfc(c) + qflx_in_h2osfc(fc) * dtime !-- if all water evaporates, there will be no bottom drainage if (h2osfc(c) < 0.0) then qflx_infl(c) = qflx_infl(c) + h2osfc(c)/dtime qflx_gross_evap_soil(c) = qflx_gross_evap_soil(c) - h2osfc(c)/dtime h2osfc(c) = 0.0 - qflx_h2osfc_drain(c)= 0._r8 + qflx_h2osfc_drain(fc)= 0._r8 else if ( use_modified_infil ) then ! Assume frac_h2osfc occurs on top of fsat if (frac_h2osfc(c) <= fsat(c)) then - qflx_h2osfc_drain(c)=0._r8 + qflx_h2osfc_drain(fc)=0._r8 else - qflx_h2osfc_drain(c)=min((frac_h2osfc(c)-fsat(c))*qinmax,h2osfc(c)/dtime) + qflx_h2osfc_drain(fc)=min((frac_h2osfc(c)-fsat(c))*qinmax,h2osfc(c)/dtime) endif else ! Original scheme - qflx_h2osfc_drain(c)=min(frac_h2osfc(c)*qinmax,h2osfc(c)/dtime) + qflx_h2osfc_drain(fc)=min(frac_h2osfc(c)*qinmax,h2osfc(c)/dtime) end if endif if(h2osfcflag==0) then - qflx_h2osfc_drain(c)= max(0._r8,h2osfc(c)/dtime) !ensure no h2osfc + qflx_h2osfc_drain(fc)= max(0._r8,h2osfc(c)/dtime) !ensure no h2osfc endif !7. remove drainage from h2osfc and add to qflx_infl - h2osfc(c) = h2osfc(c) - qflx_h2osfc_drain(c) * dtime - qflx_infl(c) = qflx_infl(c) + qflx_h2osfc_drain(c) + h2osfc(c) = h2osfc(c) - qflx_h2osfc_drain(fc) * dtime + qflx_infl(c) = qflx_infl(c) + qflx_h2osfc_drain(fc) !8. add drainage from river inundation to qflx_infl (land river two way coupling) if (use_lnd_rof_two_way) then @@ -673,10 +688,10 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f h2orof(c) = h2orof(c) - qflx_h2orof_drain(c) * dtime qflx_infl(c) = qflx_infl(c) + qflx_h2orof_drain(c) - qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c) + qflx_h2osfc_drain(c) + qflx_h2orof_drain(c) + qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c) + qflx_h2osfc_drain(fc) + qflx_h2orof_drain(c) else - qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c) + qflx_h2osfc_drain(c) + qflx_gross_infl_soil(c) = qflx_gross_infl_soil(c) + qflx_h2osfc_drain(fc) endif !9. add drainage from coastal inundation to qflx_infl (ocean land one way coupling) @@ -725,6 +740,7 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f ! No infiltration for impervious urban surfaces + !$acc parallel loop independent gang vector default(present) do fc = 1, num_urbanc c = filter_urbanc(fc) if (col_pp%itype(c) /= icol_road_perv) then @@ -738,6 +754,21 @@ subroutine Infiltration(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f end if end do + + + + !$acc exit data delete(& + !$acc vol_ice(:,:), & + !$acc alpha_evap(:), & + !$acc qflx_evap(:), & + !$acc qflx_h2osfc_drain(:), & + !$acc qflx_in_h2osfc(:), & + !$acc qflx_in_soil(:), & + !$acc qflx_infl_excess(:), & + !$acc top_moist(:), & + !$acc top_max_moist(:), & + !$acc top_ice(:)) + end associate end subroutine Infiltration @@ -750,7 +781,6 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil ! Calculate watertable, considering aquifer recharge but no drainage. ! ! !USES: - !$acc routine seq use elm_varcon , only : pondmx, tfrz, watmin,denice,denh2o use elm_varpar , only : nlevsoi, nlevgrnd use column_varcon , only : icol_roof, icol_road_imperv @@ -771,20 +801,13 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil ! !LOCAL VARIABLES: integer :: c,j,fc,i,l,g ! indices integer :: nlevbed ! # layers to bedrock - real(r8) :: xs(bounds%begc:bounds%endc) ! water needed to bring soil moisture to watmin (mm) - real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevgrnd) ! layer thickness (mm) - integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) - real(r8) :: rsub_bot(bounds%begc:bounds%endc) ! subsurface runoff - bottom drainage (mm/s) - real(r8) :: rsub_top(bounds%begc:bounds%endc) ! subsurface runoff - topographic control (mm/s) - real(r8) :: fff(bounds%begc:bounds%endc) ! decay factor (m-1) - real(r8) :: xsi(bounds%begc:bounds%endc) ! excess soil water above saturation at layer i (mm) + integer :: jwt(1:num_hydrologyc) ! index of the soil layer right above the water table (-) real(r8) :: rous ! aquifer yield (-) real(r8) :: wh ! smpfz(jwt)-z(jwt) (mm) real(r8) :: ws ! summation of pore space of layers below water table (mm) real(r8) :: s_node ! soil wetness (-) real(r8) :: dzsum ! summation of dzmm of layers below water table (mm) real(r8) :: icefracsum ! summation of icefrac*dzmm of layers below water table (-) - real(r8) :: fracice_rsub(bounds%begc:bounds%endc) ! fractional impermeability of soil layers (-) real(r8) :: ka ! hydraulic conductivity of the aquifer (mm/s) real(r8) :: dza ! fff*(zwt-z(jwt)) (-) real(r8) :: available_h2osoi_liq ! available soil liquid water in a layer @@ -847,19 +870,15 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil qflx_drain_perched => col_wf%qflx_drain_perched , & ! Output: [real(r8) (:) ] perched wt sub-surface runoff (mm H2O /s) qflx_rsub_sat => col_wf%qflx_rsub_sat & ! Output: [real(r8) (:) ] soil saturation excess [mm h2o/s] ) - + !$acc enter data create(& + !$acc jwt(:), & + !$acc qcharge_tot, & + !$acc qcharge_layer ) ! Convert layer thicknesses from m to mm - do fc = 1, num_hydrologyc - c = filter_hydrologyc(fc) - nlevbed = nlev2bed(c) - do j = 1,nlevbed - dzmm(c,j) = dz(c,j)*1.e3_r8 - end do - end do - if (.not.use_vsfm) then + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) qflx_drain(c) = 0._r8 @@ -871,17 +890,19 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil ! The layer index of the first unsaturated layer, i.e., the layer right above ! the water table + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) - jwt(c) = nlevbed + jwt(fc) = nlevbed ! allow jwt to equal zero when zwt is in top layer + !$acc loop seq do j = 1,nlevbed if(zwt(c) <= zi(c,j)) then if (zengdecker_2009_with_var_soil_thick .and. zwt(c) == zi(c,nlevbed)) then exit else - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if @@ -890,6 +911,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil !============================== QCHARGE ========================================= ! Water table changes due to qcharge + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) @@ -907,7 +929,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil wa(c) = wa(c) - qflx_grnd_irrig_col(c) * dtime zwt(c) = zwt(c) + (qflx_grnd_irrig_col(c) * dtime)/1000._r8/rous - if(jwt(c) == nlevbed) then + if(jwt(fc) == nlevbed) then if (.not. (zengdecker_2009_with_var_soil_thick)) then wa(c) = wa(c) + qcharge(c) * dtime zwt(c) = zwt(c) - (qcharge(c) * dtime)/1000._r8/rous @@ -917,10 +939,10 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil ! try to raise water table to account for qcharge qcharge_tot = qcharge(c) * dtime if(qcharge_tot > 0.) then !rising water table - do j = jwt(c)+1, 1,-1 + !$acc loop seq + do j = jwt(fc)+1, 1,-1 !scs: use analytical expression for specific yield - s_y = watsat(c,j) & - * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) + s_y = watsat(c,j) * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) s_y=max(s_y,0.02_r8) qcharge_layer=min(qcharge_tot,(s_y*(zwt(c) - zi(c,j-1))*1.e3)) @@ -932,10 +954,10 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil if (qcharge_tot <= 0.) exit enddo else ! deepening water table (negative qcharge) - do j = jwt(c)+1, nlevbed + !$acc loop seq + do j = jwt(fc)+1, nlevbed !scs: use analytical expression for specific yield - s_y = watsat(c,j) & - * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) + s_y = watsat(c,j) * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) s_y=max(s_y,0.02_r8) qcharge_layer=max(qcharge_tot,-(s_y*(zi(c,j) - zwt(c))*1.e3)) @@ -954,13 +976,13 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil !-- recompute jwt for following calculations --------------------------------- ! allow jwt to equal zero when zwt is in top layer - jwt(c) = nlevbed + jwt(fc) = nlevbed do j = 1,nlevbed if(zwt(c) <= zi(c,j)) then if (zengdecker_2009_with_var_soil_thick .and. zwt(c) == zi(c,nlevbed)) then exit else - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if @@ -972,6 +994,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil !== BASEFLOW ================================================== ! perched water table code + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) @@ -983,6 +1006,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil k_frz=1 endif + !$acc loop seq do k=2, nlevbed if (t_soisno(c,k-1) > tfrz .and. t_soisno(c,k) <= tfrz) then k_frz=k @@ -1007,6 +1031,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil sat_lev=0.9 k_perch=1 + !$acc loop seq do k=k_frz,1,-1 h2osoi_vol(c,k) = h2osoi_liq(c,k)/(dz(c,k)*denh2o) & + h2osoi_ice(c,k)/(dz(c,k)*denice) @@ -1036,6 +1061,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil endif end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) @@ -1058,6 +1084,7 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_urbanc c = filter_urbanc(fc) ! Renew the ice and liquid mass due to condensation for urban roof and impervious road @@ -1077,6 +1104,11 @@ subroutine WaterTable(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, fil end do + !$acc exit data delete(& + !$acc jwt(:), & + !$acc qcharge_tot, & + !$acc qcharge_layer ) + end associate end subroutine WaterTable @@ -1089,7 +1121,6 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! Calculate subsurface drainage ! ! !USES: - !$acc routine seq use elm_varpar , only : nlevsoi, nlevgrnd, nlayer, nlayert use elm_varcon , only : pondmx, tfrz, watmin,rpi, secspday, nlvic use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv @@ -1114,19 +1145,16 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte real(r8), intent(in) :: dtime ! ! !LOCAL VARIABLES: - !character(len=32) :: subname = 'Drainage' ! subroutine name - integer :: c,g,l,j,fc,i ! indices - integer :: nlevbed ! # layers to bedrock - real(r8) :: xs(bounds%begc:bounds%endc) ! water needed to bring soil moisture to watmin (mm) - real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevgrnd) ! layer thickness (mm) - integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) - real(r8) :: rsub_bot(bounds%begc:bounds%endc) ! subsurface runoff - bottom drainage (mm/s) - real(r8) :: rsub_top(bounds%begc:bounds%endc) ! subsurface runoff - topographic control (mm/s) - real(r8) :: fff(bounds%begc:bounds%endc) ! decay factor (m-1) - real(r8) :: xsi(bounds%begc:bounds%endc) ! excess soil water above saturation at layer i (mm) - real(r8) :: xsia(bounds%begc:bounds%endc) ! available pore space at layer i (mm) - real(r8) :: xs1(bounds%begc:bounds%endc) ! excess soil water above saturation at layer 1 (mm) - real(r8) :: smpfz(1:nlevsoi) ! matric potential of layer right above water table (mm) + character(len=32) :: subname = 'Drainage' ! subroutine name + integer :: c,j,fc,i ! indices + integer :: nlevbed ! # layers to bedrock + real(r8) :: xs(1:num_hydrologyc) ! water needed to bring soil moisture to watmin (mm) + real(r8) :: dzmm(1:num_hydrologyc,1:nlevgrnd) ! layer thickness (mm) + integer :: jwt(1:num_hydrologyc) ! index of the soil layer right above the water table (-) + real(r8) :: rsub_top(1:num_hydrologyc) ! subsurface runoff - topographic control (mm/s) + real(r8) :: fff(1:num_hydrologyc) ! decay factor (m-1) + real(r8) :: xsi(1:num_hydrologyc) ! excess soil water above saturation at layer i (mm) + real(r8) :: xs1(1:num_hydrologyc) ! excess soil water above saturation at layer 1 (mm) real(r8) :: wtsub ! summation of hk*dzmm for layers below water table (mm**2/s) real(r8) :: rous ! aquifer yield (-) real(r8) :: wh ! smpfz(jwt)-z(jwt) (mm) @@ -1135,7 +1163,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte real(r8) :: s_node ! soil wetness (-) real(r8) :: dzsum ! summation of dzmm of layers below water table (mm) real(r8) :: icefracsum ! summation of icefrac*dzmm of layers below water table (-) - real(r8) :: fracice_rsub(bounds%begc:bounds%endc) ! fractional impermeability of soil layers (-) + real(r8) :: fracice_rsub(1:num_hydrologyc) ! fractional impermeability of soil layers (-) real(r8) :: ka ! hydraulic conductivity of the aquifer (mm/s) real(r8) :: dza ! fff*(zwt-z(jwt)) (-) real(r8) :: available_h2osoi_liq ! available soil liquid water in a layer @@ -1158,7 +1186,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte real(r8) :: q_perch real(r8) :: q_perch_max real(r8) :: vol_ice - real(r8) :: dsmax_tmp(bounds%begc:bounds%endc) ! temporary variable for ARNO subsurface runoff calculation + real(r8) :: dsmax_tmp(1:num_hydrologyc) ! temporary variable for ARNO subsurface runoff calculation real(r8) :: rsub_tmp ! temporary variable for ARNO subsurface runoff calculation real(r8) :: frac ! temporary variable for ARNO subsurface runoff calculation real(r8) :: rel_moist ! relative moisture, temporary variable @@ -1222,15 +1250,26 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte h2osoi_liq => col_ws%h2osoi_liq , & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) h2osoi_ice => col_ws%h2osoi_ice & ! Output: [real(r8) (:,:) ] ice lens (kg/m2) ) - + !$acc enter data create(& + !$acc xs(:), & + !$acc dzmm(:,:), & + !$acc jwt(:), & + !$acc rsub_top(:), & + !$acc fff(:), & + !$acc xsi(:), & + !$acc xs1(:), & + !$acc fracice_rsub(:), & + !$acc dsmax_tmp(:)) ! Convert layer thicknesses from m to mm + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1,nlevbed - dzmm(c,j) = dz(c,j)*1.e3_r8 + dzmm(fc,j) = dz(c,j)*1.e3_r8 vol_ice = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) icefrac(c,j) = min(1._r8,vol_ice/watsat(c,j)) @@ -1239,42 +1278,45 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! Initial set + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) qflx_drain(c) = 0._r8 qflx_lnd2ocn(c) = 0._r8 rsub_bot(c) = 0._r8 qflx_rsub_sat(c) = 0._r8 - rsub_top(c) = 0._r8 - fracice_rsub(c) = 0._r8 + rsub_top(fc) = 0._r8 + fracice_rsub(fc) = 0._r8 qflx_qrgwl(c) = 0._r8 end do ! The layer index of the first unsaturated layer, i.e., the layer right above ! the water table - do fc = 1, num_hydrologyc !TODO: introduce a filter for coastline grid cells + !$acc parallel loop independent gang vector default(present) + do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) g = col_pp%gridcell(c) nlevbed = nlev2bed(c) - jwt(c) = nlevbed + jwt(fc) = nlevbed ! allow jwt to equal zero when zwt is in top layer + !$acc loop seq do j = 1,nlevbed if (zwt(c) <= zi(c,j)) then if (zengdecker_2009_with_var_soil_thick .and. zwt(c) == zi(c,nlevbed)) then exit else - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if enddo end do - rous = 0.2_r8 !== BASEFLOW ================================================== ! perched water table code + !$acc parallel loop independent gang vector default(present) present(ice(:,:),moist(:,:) ) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) @@ -1291,7 +1333,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte else k_frz=1 endif - + !$acc loop seq do k=2, nlevbed if (t_soisno(c,k-1) > tfrz .and. t_soisno(c,k) <= tfrz) then k_frz=k @@ -1313,19 +1355,20 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! compute drainage from perched saturated region wtsub = 0._r8 q_perch = 0._r8 - do k = jwt(c)+1, k_frz + !$acc loop seq + do k = jwt(fc)+1, k_frz imped=10._r8**(-e_ice*(0.5_r8*(icefrac(c,k)+icefrac(c,min(nlevbed, k+1))))) - q_perch = q_perch + imped*hksat(c,k)*dzmm(c,k) - wtsub = wtsub + dzmm(c,k) + q_perch = q_perch + imped*hksat(c,k)*dzmm(fc,k) + wtsub = wtsub + dzmm(fc,k) end do if (wtsub > 0._r8) q_perch = q_perch/wtsub - qflx_drain_perched(c) = q_perch_max * q_perch & - *(frost_table(c) - zwt(c)) + qflx_drain_perched(c) = q_perch_max * q_perch * (frost_table(c) - zwt(c)) ! remove drainage from perched saturated layers rsub_top_tot = - qflx_drain_perched(c) * dtime - do k = jwt(c)+1, k_frz + !$acc loop seq + do k = jwt(fc)+1, k_frz rsub_top_layer=max(rsub_top_tot,-(h2osoi_liq(c,k)-watmin)) rsub_top_layer=min(rsub_top_layer,0._r8) if (use_vsfm) then @@ -1344,18 +1387,19 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte enddo ! if rsub_top_tot is greater than available water (above frost table), - ! then decrease qflx_drain_perched by residual amount for water balance + ! then decrease qflx_drain_perched by residual amount for water balance qflx_drain_perched(c) = qflx_drain_perched(c) + rsub_top_tot/dtime !-- recompute jwt --------------------------------------------------------- ! allow jwt to equal zero when zwt is in top layer - jwt(c) = nlevbed + jwt(fc) = nlevbed + !$acc loop seq do j = 1,nlevbed if(zwt(c) <= zi(c,j)) then if (zengdecker_2009_with_var_soil_thick .and. zwt(c) == zi(c,nlevbed)) then exit else - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if @@ -1368,6 +1412,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte sat_lev=0.9 k_perch=1 + !$acc loop seq do k=k_frz,1,-1 h2osoi_vol = h2osoi_liq(c,k)/(dz(c,k)*denh2o) & + h2osoi_ice(c,k)/(dz(c,k)*denice) @@ -1396,10 +1441,11 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! compute drainage from perched saturated region wtsub = 0._r8 q_perch = 0._r8 + !$acc loop seq do k = k_perch, k_frz imped=10._r8**(-e_ice*(0.5_r8*(icefrac(c,k)+icefrac(c,min(nlevbed, k+1))))) - q_perch = q_perch + imped*hksat(c,k)*dzmm(c,k) - wtsub = wtsub + dzmm(c,k) + q_perch = q_perch + imped*hksat(c,k)*dzmm(fc,k) + wtsub = wtsub + dzmm(fc,k) end do if (wtsub > 0._r8) q_perch = q_perch/wtsub @@ -1411,6 +1457,7 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! remove drainage from perched saturated layers rsub_top_tot = - qflx_drain_perched(c) * dtime + !$acc loop seq do k = k_perch+1, k_frz rsub_top_layer=max(rsub_top_tot,-(h2osoi_liq(c,k)-watmin)) rsub_top_layer=min(rsub_top_layer,0._r8) @@ -1437,30 +1484,31 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte endif !k_frz > k_perch !-- Topographic runoff ---------------------------------------------------------------------- - fff(c) = 1._r8/ hkdepth(c) + fff(fc) = 1._r8/ hkdepth(c) dzsum = 0._r8 icefracsum = 0._r8 - do j = max(jwt(c),1), nlevbed - dzsum = dzsum + dzmm(c,j) - icefracsum = icefracsum + icefrac(c,j) * dzmm(c,j) + !$acc loop seq + do j = max(jwt(fc),1), nlevbed + dzsum = dzsum + dzmm(fc,j) + icefracsum = icefracsum + icefrac(c,j) * dzmm(fc,j) end do ! add ice impedance factor to baseflow if(origflag == 1) then if (use_vichydro) then #ifndef _OPENACC - call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(__FILE__, __LINE__)) + call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(__FILE__, __LINE__)) #endif else - fracice_rsub(c) = max(0._r8,exp(-3._r8*(1._r8-(icefracsum/dzsum))) & + fracice_rsub(fc) = max(0._r8,exp(-3._r8*(1._r8-(icefracsum/dzsum))) & - exp(-3._r8))/(1.0_r8-exp(-3._r8)) - imped=(1._r8 - fracice_rsub(c)) + imped=(1._r8 - fracice_rsub(fc)) rsub_top_max = 5.5e-3_r8 end if else if (use_vichydro) then imped=10._r8**(-e_ice*min(1.0_r8,ice(c,nlayer)/max_moist(c,nlayer))) - dsmax_tmp(c) = Dsmax(c) * dtime/ secspday !mm/day->mm/dtime - rsub_top_max = dsmax_tmp(c) + dsmax_tmp(fc) = Dsmax(c) * dtime/ secspday !mm/day->mm/dtime + rsub_top_max = dsmax_tmp(fc) else imped=10._r8**(-e_ice*(icefracsum/dzsum)) rsub_top_max = min(10._r8 * sin((rpi/180.) * col_pp%topo_slope(c)), rsub_top_globalmax) @@ -1477,20 +1525,18 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte frac = (rel_moist - Wsvic(c))/(1.0_r8 - Wsvic(c)) rsub_tmp = rsub_tmp + (rsub_top_max * (1.0_r8 - Ds(c)/Wsvic(c)) *frac**c_param(c))/dtime end if - rsub_top(c) = imped * rsub_tmp + rsub_top(fc) = imped * rsub_tmp ! make sure baseflow isn't negative - rsub_top(c) = max(0._r8, rsub_top(c)) + rsub_top(fc) = max(0._r8, rsub_top(fc)) else - - if (jwt(c) == nlevbed .and. zengdecker_2009_with_var_soil_thick) then - rsub_top(c) = 0._r8 + if (jwt(fc) == nlevbed .and. zengdecker_2009_with_var_soil_thick) then + rsub_top(fc) = 0._r8 else - rsub_top(c) = imped * rsub_top_max* exp(-fff(c)*zwt(c)) - end if - + rsub_top(fc) = imped * rsub_top_max* exp(-fff(fc)*zwt(c)) + end if end if - if (use_vsfm) rsub_top(c) = 0._r8 + if (use_vsfm) rsub_top(fc) = 0._r8 ! use analytical expression for aquifer specific yield rous = watsat(c,nlevbed) & @@ -1498,62 +1544,61 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte rous=max(rous,0.02_r8) !-- water table is below the soil column -------------------------------------- - if(jwt(c) == nlevbed) then - if (zengdecker_2009_with_var_soil_thick) then - if (-1._r8 * smp_l(c,nlevbed) < 0.5_r8 * dzmm(c,nlevbed)) then - zwt(c) = z(c,nlevbed) - (smp_l(c,nlevbed) / 1000._r8) - end if - rsub_top(c) = imped * rsub_top_max * exp(-fff(c) * zwt(c)) - rsub_top_tot = - rsub_top(c) * dtime - s_y = watsat(c,nlevbed) & - * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,nlevbed))**(-1./bsw(c,nlevbed))) - s_y=max(s_y,0.02_r8) - rsub_top_layer=max(rsub_top_tot,-(s_y*(zi(c,nlevbed) - zwt(c))*1.e3_r8)) - rsub_top_layer=min(rsub_top_layer,0._r8) - h2osoi_liq(c,nlevbed) = h2osoi_liq(c,nlevbed) + rsub_top_layer - rsub_top_tot = rsub_top_tot - rsub_top_layer - if (rsub_top_tot >= 0._r8) then - zwt(c) = zwt(c) - rsub_top_layer/s_y/1000._r8 - else - zwt(c) = zi(c,nlevbed) - end if - if (rsub_top_tot < 0.) then - rsub_top(c) = rsub_top(c) + rsub_top_tot / dtime - rsub_top_tot = 0. - end if - - else - wa(c) = wa(c) - rsub_top(c) * dtime - zwt(c) = zwt(c) + (rsub_top(c) * dtime)/1000._r8/rous - h2osoi_liq(c,nlevsoi) = h2osoi_liq(c,nlevsoi) + max(0._r8,(wa(c)-5000._r8)) - wa(c) = min(wa(c), 5000._r8) - end if - else - !-- water table within soil layers 1-9 ------------------------------------- - !============================== RSUB_TOP ========================================= - !-- Now remove water via rsub_top - rsub_top_tot = - rsub_top(c) * dtime - !should never be positive... but include for completeness - if(rsub_top_tot > 0.) then !rising water table -#ifndef _OPENACC - call endrun(msg="RSUB_TOP IS POSITIVE in Drainage!"//errmsg(__FILE__, __LINE__)) -#endif - else ! deepening water table + if(jwt(fc) == nlevbed) then + if (zengdecker_2009_with_var_soil_thick) then + if (-1._r8 * smp_l(c,nlevbed) < 0.5_r8 * dzmm(fc,nlevbed)) then + zwt(c) = z(c,nlevbed) - (smp_l(c,nlevbed) / 1000._r8) + end if + rsub_top(fc) = imped * rsub_top_max * exp(-fff(fc) * zwt(c)) + rsub_top_tot = - rsub_top(fc) * dtime + s_y = watsat(c,nlevbed) & + * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,nlevbed))**(-1./bsw(c,nlevbed))) + s_y=max(s_y,0.02_r8) + rsub_top_layer=max(rsub_top_tot,-(s_y*(zi(c,nlevbed) - zwt(c))*1.e3)) + rsub_top_layer=min(rsub_top_layer,0._r8) + h2osoi_liq(c,nlevbed) = h2osoi_liq(c,nlevbed) + rsub_top_layer + rsub_top_tot = rsub_top_tot - rsub_top_layer + if (rsub_top_tot >= 0._r8) then + zwt(c) = zwt(c) - rsub_top_layer/s_y/1000._r8 + else + zwt(c) = zi(c,nlevbed) + end if + if (rsub_top_tot < 0.) then + rsub_top(fc) = rsub_top(fc) + rsub_top_tot / dtime + rsub_top_tot = 0. + end if + else + wa(c) = wa(c) - rsub_top(fc) * dtime + zwt(c) = zwt(c) + (rsub_top(fc) * dtime)/1000._r8/rous + h2osoi_liq(c,nlevsoi) = h2osoi_liq(c,nlevsoi) + max(0._r8,(wa(c)-5000._r8)) + wa(c) = min(wa(c), 5000._r8) + end if + else + !-- water table within soil layers 1-9 ------------------------------------- + !============================== RSUB_TOP ========================================= + !-- Now remove water via rsub_top + rsub_top_tot = - rsub_top(fc) * dtime + !should never be positive... but include for completeness + if(rsub_top_tot > 0.) then !rising water table + call endrun(msg="RSUB_TOP IS POSITIVE in Drainage!"//errmsg(__FILE__, __LINE__)) + else ! deepening water table if (use_vichydro) then wtsub_vic = 0._r8 + !$acc loop seq do j = (nlvic(1)+nlvic(2)+1), nlevbed - wtsub_vic = wtsub_vic + hk_l(c,j)*dzmm(c,j) + wtsub_vic = wtsub_vic + hk_l(c,j)*dzmm(fc,j) end do - + !$acc loop seq do j = (nlvic(1)+nlvic(2)+1), nlevbed - rsub_top_layer=max(rsub_top_tot, rsub_top_tot*hk_l(c,j)*dzmm(c,j)/wtsub_vic) + rsub_top_layer=max(rsub_top_tot, rsub_top_tot*hk_l(c,j)*dzmm(fc,j)/wtsub_vic) rsub_top_layer=min(rsub_top_layer,0._r8) if (use_vsfm) rsub_top_layer = 0._r8 h2osoi_liq(c,j) = h2osoi_liq(c,j) + rsub_top_layer rsub_top_tot = rsub_top_tot - rsub_top_layer end do else - do j = jwt(c)+1, nlevbed + !$acc loop seq + do j = jwt(fc)+1, nlevbed ! use analytical expression for specific yield s_y = watsat(c,j) & * ( 1. - (1.+1.e3*zwt(c)/sucsat(c,j))**(-1./bsw(c,j))) @@ -1579,24 +1624,25 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte !-- remove residual rsub_top --------------------------------------------- if (zengdecker_2009_with_var_soil_thick) then if (rsub_top_tot < 0.) then - rsub_top(c) = rsub_top(c) + rsub_top_tot / dtime + rsub_top(fc) = rsub_top(fc) + rsub_top_tot / dtime rsub_top_tot = 0._r8 end if else zwt(c) = zwt(c) - rsub_top_tot/1000._r8/rous wa(c) = wa(c) + rsub_top_tot end if - endif + endif !-- recompute jwt --------------------------------------------------------- ! allow jwt to equal zero when zwt is in top layer - jwt(c) = nlevbed + jwt(fc) = nlevbed + !$acc loop seq do j = 1,nlevbed if(zwt(c) <= zi(c,j)) then if (zengdecker_2009_with_var_soil_thick .and. zwt(c) == zi(c,nlevbed)) then exit else - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if @@ -1639,125 +1685,129 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte ! excessive water above saturation added to the above unsaturated layer like a bucket ! if column fully saturated, excess water goes to runoff + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) - + !$acc loop seq do j = nlevbed,2,-1 - xsi(c) = max(h2osoi_liq(c,j)-eff_porosity(c,j)*dzmm(c,j),0._r8) + xsi(fc) = max(h2osoi_liq(c,j)-eff_porosity(c,j)*dzmm(fc,j),0._r8) if (use_vsfm) then - xsi(c) = 0._r8 + xsi(fc) = 0._r8 else - h2osoi_liq(c,j) = min(eff_porosity(c,j)*dzmm(c,j), h2osoi_liq(c,j)) - h2osoi_liq(c,j-1) = h2osoi_liq(c,j-1) + xsi(c) + h2osoi_liq(c,j) = min(eff_porosity(c,j)*dzmm(fc,j), h2osoi_liq(c,j)) + h2osoi_liq(c,j-1) = h2osoi_liq(c,j-1) + xsi(fc) endif end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) l = col_pp%landunit(c) !scs: watmin addition to fix water balance errors - xs1(c) = max(max(h2osoi_liq(c,1)-watmin,0._r8)- & - max(0._r8,(pondmx+watsat(c,1)*dzmm(c,1)-h2osoi_ice(c,1)-watmin)),0._r8) - if (use_vsfm) xs1(c) = 0._r8 - h2osoi_liq(c,1) = h2osoi_liq(c,1) - xs1(c) + xs1(fc) = max(max(h2osoi_liq(c,1)-watmin,0._r8)- & + max(0._r8,(pondmx+watsat(c,1)*dzmm(fc,1)-h2osoi_ice(c,1)-watmin)),0._r8) + if (use_vsfm) xs1(fc) = 0._r8 + h2osoi_liq(c,1) = h2osoi_liq(c,1) - xs1(fc) if (lun_pp%urbpoi(l)) then - qflx_rsub_sat(c) = xs1(c) / dtime + qflx_rsub_sat(c) = xs1(fc) / dtime else if(h2osfcflag == 1) then ! send this water up to h2osfc rather than sending to drainage - h2osfc(c) = h2osfc(c) + xs1(c) + h2osfc(c) = h2osfc(c) + xs1(fc) qflx_rsub_sat(c) = 0._r8 else ! use original code to send water to drainage (non-h2osfc case) - qflx_rsub_sat(c) = xs1(c) / dtime + qflx_rsub_sat(c) = xs1(fc) / dtime endif endif if (use_vsfm) qflx_rsub_sat(c) = 0._r8 ! add in ice check - xs1(c) = max(max(h2osoi_ice(c,1),0._r8)-max(0._r8,(pondmx+watsat(c,1)*dzmm(c,1)-h2osoi_liq(c,1))),0._r8) + xs1(fc) = max(max(h2osoi_ice(c,1),0._r8)-max(0._r8,(pondmx+watsat(c,1)*dzmm(fc,1)-h2osoi_liq(c,1))),0._r8) h2osoi_ice(c,1) = min(max(0._r8,pondmx+watsat(c,1)*dzmm(c,1)-h2osoi_liq(c,1)), h2osoi_ice(c,1)) if ( (lun_pp%itype(l) == istice .or. lun_pp%itype(l) == istice_mec) .or. (.not. use_firn_percolation_and_compaction)) then - qflx_snwcp_ice(c) = qflx_snwcp_ice(c) + xs1(c) / dtime + qflx_snwcp_ice(c) = qflx_snwcp_ice(c) + xs1(fc) / dtime else - qflx_ice_runoff_xs(c) = qflx_ice_runoff_xs(c) + xs1(c) / dtime + qflx_ice_runoff_xs(c) = qflx_ice_runoff_xs(c) + xs1(fc) / dtime endif end do ! Limit h2osoi_liq to be greater than or equal to watmin. ! Get water needed to bring h2osoi_liq equal watmin from lower layer. ! If insufficient water in soil layers, get from aquifer water - + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed-1 - if (h2osoi_liq(c,j) < watmin) then - xs(c) = watmin - h2osoi_liq(c,j) - ! deepen water table if water is passed from below zwt layer - if(j == jwt(c)) then - zwt(c) = zwt(c) + xs(c)/eff_porosity(c,j)/1000._r8 - endif - else - xs(c) = 0._r8 - end if - h2osoi_liq(c,j ) = h2osoi_liq(c,j ) + xs(c) - h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) - xs(c) + if (h2osoi_liq(c,j) < watmin) then + xs(fc) = watmin - h2osoi_liq(c,j) + ! deepen water table if water is passed from below zwt layer + if(j == jwt(fc)) then + zwt(c) = zwt(c) + xs(fc)/eff_porosity(c,j)/1000._r8 + endif + else + xs(fc) = 0._r8 + end if + h2osoi_liq(c,j ) = h2osoi_liq(c,j ) + xs(fc) + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) - xs(fc) end do end do ! Get water for bottom layer from layers above if possible + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) j = nlevbed if (h2osoi_liq(c,j) < watmin) then - xs(c) = watmin-h2osoi_liq(c,j) + xs(fc) = watmin-h2osoi_liq(c,j) + !$acc loop seq searchforwater: do i = nlevbed-1, 1, -1 - available_h2osoi_liq = max(h2osoi_liq(c,i)-watmin-xs(c),0._r8) - if (available_h2osoi_liq >= xs(c)) then - h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c) - h2osoi_liq(c,i) = h2osoi_liq(c,i) - xs(c) - xs(c) = 0._r8 + available_h2osoi_liq = max(h2osoi_liq(c,i)-watmin-xs(fc),0._r8) + if (available_h2osoi_liq >= xs(fc)) then + h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(fc) + h2osoi_liq(c,i) = h2osoi_liq(c,i) - xs(fc) + xs(fc) = 0._r8 exit searchforwater else h2osoi_liq(c,j) = h2osoi_liq(c,j) + available_h2osoi_liq h2osoi_liq(c,i) = h2osoi_liq(c,i) - available_h2osoi_liq - xs(c) = xs(c) - available_h2osoi_liq + xs(fc) = xs(fc) - available_h2osoi_liq end if end do searchforwater else - xs(c) = 0._r8 + xs(fc) = 0._r8 end if ! Needed in case there is no water to be found - h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(fc) ! Instead of removing water from aquifer where it eventually ! shows up as excess drainage to the ocean, take it back out of ! drainage - rsub_top(c) = rsub_top(c) - xs(c)/dtime - + rsub_top(fc) = rsub_top(fc) - xs(fc)/dtime end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - + ! Sub-surface runoff and drainage - - qflx_drain(c) = qflx_rsub_sat(c) + rsub_top(c) + qflx_drain(c) = qflx_rsub_sat(c) + rsub_top(fc) ! Set imbalance for snow capping - qflx_qrgwl(c) = qflx_snwcp_liq(c) end do ! No drainage for urban columns (except for pervious road as computed above) + !$acc parallel loop independent gang vector default(present) do fc = 1, num_urbanc c = filter_urbanc(fc) if (col_pp%itype(c) /= icol_road_perv) then @@ -1768,6 +1818,17 @@ subroutine Drainage(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, filte end if end do + !$acc exit data delete(& + !$acc xs(:), & + !$acc dzmm(:,:), & + !$acc jwt(:), & + !$acc rsub_top(:), & + !$acc fff(:), & + !$acc xsi(:), & + !$acc xs1(:), & + !$acc fracice_rsub(:), & + !$acc dsmax_tmp(:)) + end associate end subroutine Drainage @@ -1993,7 +2054,7 @@ subroutine DrainageVSFM(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f ! Calculate subsurface drainage ! ! !USES: - !$acc routine seq + !$acc routine seq use elm_varpar , only : nlevsoi, nlevgrnd, nlayer, nlayert use elm_varcon , only : pondmx, tfrz, watmin,rpi, secspday, nlvic use column_varcon , only : icol_roof, icol_road_imperv, icol_road_perv @@ -2161,7 +2222,7 @@ subroutine DrainageVSFM(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f ! perched water table code do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - + ! specify maximum drainage rate q_perch_max = 1.e-5_r8 * sin(col_pp%topo_slope(c) * (rpi/180._r8)) @@ -2327,9 +2388,9 @@ subroutine DrainageVSFM(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f ! add ice impedance factor to baseflow if(origflag == 1) then if (use_vichydro) then -#ifndef _OPENACC - call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(__FILE__, __LINE__)) -#endif + #ifndef _OPENACC + call endrun(msg="VICHYDRO is not available for origflag=1"//errmsg(__FILE__, __LINE__)) + #endif else fracice_rsub(c) = max(0._r8,exp(-3._r8*(1._r8-(icefracsum/dzsum))) & - exp(-3._r8))/(1.0_r8-exp(-3._r8)) @@ -2361,6 +2422,7 @@ subroutine DrainageVSFM(bounds, num_hydrologyc, filter_hydrologyc, num_urbanc, f ! make sure baseflow isn't negative rsub_top(c) = max(0._r8, rsub_top(c)) else + rsub_top(c) = imped * rsub_top_max* exp(-fff(c)*zwt(c)) end if endif @@ -2409,7 +2471,7 @@ subroutine ELMVICMap(bounds, numf, filter, & ! mapping from VIC to CLM layers, M.Huang ! ! !USES: - !$acc routine seq + !$acc routine seq use elm_varcon , only : denh2o, denice, watmin use elm_varpar , only : nlevsoi, nlayer, nlayert, nlevgrnd use decompMod , only : bounds_type diff --git a/components/elm/src/biogeophys/SoilMoistStressMod.F90 b/components/elm/src/biogeophys/SoilMoistStressMod.F90 index f9c3ed870ec3..3443fe22a2da 100644 --- a/components/elm/src/biogeophys/SoilMoistStressMod.F90 +++ b/components/elm/src/biogeophys/SoilMoistStressMod.F90 @@ -26,14 +26,13 @@ module SoilMoistStressMod public :: calc_volumetric_h2oliq public :: set_perchroot_opt public :: init_root_moist_stress + private :: normalize_test ! ! !PRIVATE DATA MEMBERS: integer :: root_moist_stress_method integer, parameter :: moist_stress_clm_default = 0 !default method for calculating root moisture stress logical, private :: perchroot = .false. ! true => btran is based only on unfrozen soil levels logical, private :: perchroot_alt = .false. ! true => btran is based on active layer (defined over two years); - !$acc declare create(root_moist_stress_method) - !$acc declare copyin(moist_stress_clm_default) !$acc declare create(perchroot) !$acc declare create(perchroot_alt) @@ -41,6 +40,53 @@ module SoilMoistStressMod contains +subroutine normalize_test( lbj2, ubj2, numf, filter, arr2d_inout) + !DESCRIPTIONS + !do normalization with filter for the input array along dimension 2 + ! + !USES + use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none + + integer, intent(in) :: lbj2 !right bound of dim 1 + integer, intent(in) :: ubj2 !right bound of dim 2 + integer, intent(in) :: numf !filter size + integer, intent(in) :: filter(:) !filter + real(r8), intent(inout) :: arr2d_inout(: , : ) !input 2d array + + !local variables + integer :: sz1, sz2 !array size + integer :: j2 !indices + integer :: f, p !indices + real(r8) :: arr_sum(numf), sum1 + + !$acc enter data create(arr_sum(1:numf)) + !$acc parallel loop independent gang worker default(present) private(sum1) + do f = 1, numf + sum1 = 0._r8 + !$acc loop vector reduction(+:sum1) + do j2 = lbj2, ubj2 + !obtain the total + sum1=sum1+arr2d_inout(f,j2) + enddo + arr_sum(f) = sum1 + enddo + + !normalize with the total if arr_sum is non-zero + !$acc parallel loop independent gang default(present) + do j2 = lbj2, ubj2 + !$acc loop vector independent + do f = 1, numf + !I found I have to ensure >0._r8 because of some unknown reason, jyt May 23, 2014 + !I will test this later with arr_sum(p)/=0._r8 + if(arr_sum(f)>0._r8 .or. arr_sum(f)<0._r8)then + arr2d_inout(f,j2) = arr2d_inout(f,j2)/arr_sum(f) + endif + enddo + enddo + !$acc exit data delete(arr_sum(:)) +end subroutine normalize_test + !-------------------------------------------------------------------------------- subroutine init_root_moist_stress() ! @@ -50,7 +96,6 @@ subroutine init_root_moist_stress() implicit none root_moist_stress_method = moist_stress_clm_default - !$acc update device(root_moist_stress_method) end subroutine init_root_moist_stress !-------------------------------------------------------------------------------- @@ -81,10 +126,10 @@ subroutine calc_effective_soilporosity(bounds, ubj, numf, filter, & ! compute the effective soil porosity ! ! !USES - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 use decompMod , only : bounds_type use ColumnType , only : col_pp + use VegetationType , only : veg_pp ! ! !ARGUMENTS: implicit none @@ -98,23 +143,24 @@ subroutine calc_effective_soilporosity(bounds, ubj, numf, filter, & real(r8) , intent(inout) :: eff_por( bounds%begc: ,1: ) ! effective porosity ! ! !LOCAL VARIABLES: - integer :: c, j, fc !indices + integer :: c, j, fp,p !indices real(r8):: vol_ice !volumetric ice !------------------------------------------------------------------------------ - - ! Enforce expected array sizes - !main calculation loop !it assumes the soil layers start from 1 + !$acc parallel loop independent gang default(present) do j = 1, ubj - do fc = 1, numf - c = filter(fc) + !$acc loop vector independent private(p,c,vol_ice) + do fp = 1, numf + p = filter(fp) + c = veg_pp%column(p) !compute the volumetric ice content vol_ice=min(watsat(c,j), h2osoi_ice(c,j)/(denice*col_pp%dz(c,j))) !compute the maximum soil space to fill liquid water and air eff_por(c,j) = watsat(c,j) - vol_ice enddo enddo + end subroutine calc_effective_soilporosity !-------------------------------------------------------------------------------- @@ -148,7 +194,6 @@ subroutine calc_effective_snowporosity(bounds, lbj, jtop, numf, filter, & ubj = 0 - ! Enforce expected array sizes !main calculation loop !it assumes snow layer ends at 0 @@ -168,7 +213,7 @@ subroutine calc_effective_snowporosity(bounds, lbj, jtop, numf, filter, & end subroutine calc_effective_snowporosity !-------------------------------------------------------------------------------- - subroutine calc_volumetric_h2oliq(bounds, jtop, lbj, ubj, numf, filter,& + subroutine calc_volumetric_h2oliq(bounds, lbj, ubj, numf, filter,& eff_porosity, h2osoi_liq, denh2o, vol_liq) ! ! !DESCRIPTIONS @@ -176,15 +221,14 @@ subroutine calc_volumetric_h2oliq(bounds, jtop, lbj, ubj, numf, filter,& ! ! ! !USES - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 use decompMod , only : bounds_type use ColumnType , only : col_pp + use VegetationType , only : veg_pp ! ! !ARGUMENTS: implicit none type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: jtop( bounds%begc: ) ! top level for each column [col] integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices integer , intent(in) :: numf ! filter dimension integer , intent(in) :: filter(:) ! filter @@ -194,16 +238,17 @@ subroutine calc_volumetric_h2oliq(bounds, jtop, lbj, ubj, numf, filter,& real(r8) , intent(inout) :: vol_liq(bounds%begc: , lbj: ) ! volumetric liquid water content ! ! !LOCAL VARIABLES: - integer :: c, j, fc ! indices + integer :: p, c, j, fp ! indices + integer, parameter :: jtop = 1 !------------------------------------------------------------------------------ - - ! Enforce expected array sizes - !main calculation loop + !$acc parallel loop independent gang default(present) do j = lbj, ubj - do fc = 1, numf - c = filter(fc) - if(j>=jtop(c))then + !$acc loop vector independent private(p,c) + do fp = 1, numf + p = filter(fp) + c = veg_pp%column(p) + if(j>=jtop)then !volume of liquid is no greater than effective void space vol_liq(c,j) = min(eff_porosity(c,j), h2osoi_liq(c,j)/(col_pp%dz(c,j)*denh2o)) endif @@ -220,7 +265,6 @@ subroutine normalize_unfrozen_rootfr(bounds, ubj, fn, filterp, & ! normalize root fraction for total unfrozen depth ! ! !USES - !$acc routine seq use shr_kind_mod , only: r8 => shr_kind_r8 use elm_varcon , only : tfrz !temperature where water freezes [K], this is taken as constant at the moment use decompMod , only : bounds_type @@ -228,7 +272,7 @@ subroutine normalize_unfrozen_rootfr(bounds, ubj, fn, filterp, & use EnergyFluxType , only : energyflux_type use SoilStateType , only : soilstate_type use SimpleMathMod , only : array_normalization - use VegetationType , only : veg_pp + use VegetationType , only : veg_pp ! ! !ARGUMENTS: implicit none @@ -238,16 +282,15 @@ subroutine normalize_unfrozen_rootfr(bounds, ubj, fn, filterp, & integer , intent(in) :: filterp(:) !filter type(canopystate_type) , intent(in) :: canopystate_vars type(soilstate_type) , intent(in) :: soilstate_vars - real(r8) , intent(inout) :: rootfr_unf(bounds%begp:bounds%endp, 1:ubj) !normalized root fraction in unfrozen layers + real(r8) , intent(inout) :: rootfr_unf(:,:) !normalized root fraction in unfrozen layers ! ! !LOCAL VARIABLES: - !real(r8) :: rootsum(bounds%begp:bounds%endp) integer :: p, c, j, f !indices + real(r8) :: arr_sum(fn), sum1 !------------------------------------------------------------------------------ - associate( & - rootfr => soilstate_vars%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer - + associate( & + rootfr => soilstate_vars%rootfr_patch , & ! Input: [real(r8) (:,:) ] fraction of roots in each soil layer t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) (-nlevsno+1:nlevgrnd) altmax_lastyear_indx => canopystate_vars%altmax_lastyear_indx_col , & ! Input: [real(r8) (:) ] prior year maximum annual depth of thaw @@ -262,58 +305,85 @@ subroutine normalize_unfrozen_rootfr(bounds, ubj, fn, filterp, & ! to zero within similar coding style. Jinyun Tang, May 23, 2014. ! Define rootfraction for unfrozen soil only - if (perchroot .or. perchroot_alt) then + ! if (perchroot .or. perchroot_alt) then if (perchroot_alt) then ! use total active layer (defined ass max thaw depth for current and prior year) + !$acc parallel loop independent gang default(present) do j = 1, ubj + !$acc loop vector independent private(p,c) do f = 1, fn p = filterp(f) c = veg_pp%column(p) if ( j <= max(altmax_lastyear_indx(c), altmax_indx(c), 1) )then - rootfr_unf(p,j) = rootfr(p,j) + rootfr_unf(f,j) = rootfr(p,j) else - rootfr_unf(p,j) = 0._r8 + rootfr_unf(f,j) = 0._r8 end if end do end do else ! use instantaneous temperature + !$acc parallel loop independent gang default(present) do j = 1, ubj + !$acc loop vector independent private(p,c) do f = 1, fn p = filterp(f) c = veg_pp%column(p) if (t_soisno(c,j) >= tfrz) then - rootfr_unf(p,j) = rootfr(p,j) + rootfr_unf(f,j) = rootfr(p,j) else - rootfr_unf(p,j) = 0._r8 + rootfr_unf(f,j) = 0._r8 end if end do end do end if ! perchroot_alt - end if ! perchroot + ! end if ! perchroot !normalize the root fraction for each pft - call array_normalization(bounds%begp, bounds%endp, 1, ubj, & - fn, filterp, rootfr_unf(bounds%begp:bounds%endp, 1:ubj)) - + ! call normalize_test( 1, ubj, & + ! fn, filterp, rootfr_unf(:, :)) + ! !!! + !$acc enter data create(arr_sum(1:fn)) + !$acc parallel loop independent gang worker default(present) private(sum1) + do f = 1, fn + sum1 = 0._r8 + !$acc loop vector reduction(+:sum1) + do j = 1, ubj + !obtain the total + sum1=sum1+rootfr_unf(f,j) + enddo + arr_sum(f) = sum1 + enddo + + !normalize with the total if arr_sum is non-zero + !$acc parallel loop independent gang default(present) + do j = 1, ubj + !$acc loop vector independent + do f = 1, fn + !I found I have to ensure >0._r8 because of some unknown reason, jyt May 23, 2014 + !I will test this later with arr_sum(p)/=0._r8 + if(arr_sum(f)>0._r8 .or. arr_sum(f)<0._r8)then + rootfr_unf(f,j) = rootfr_unf(f,j)/arr_sum(f) + endif + enddo + enddo + !$acc exit data delete(arr_sum(:)) end associate end subroutine normalize_unfrozen_rootfr !-------------------------------------------------------------------------------- - subroutine calc_root_moist_stress_clm45default(bounds, & - nlevgrnd, fn, filterp, rootfr_unf, & - soilstate_vars, energyflux_vars) + subroutine calc_root_moist_stress_clm45default( & + nlevgrnd, fn, filterp, rootfr_unf, & + soilstate_vars, energyflux_vars) ! ! DESCRIPTIONS ! compute the root water stress using the default clm45 approach ! ! USES - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 - use decompMod , only : bounds_type use elm_varcon , only : tfrz !temperature where water freezes [K], this is taken as constant at the moment use VegetationPropertiesType , only : veg_vp use SoilStateType , only : soilstate_type @@ -323,18 +393,17 @@ subroutine calc_root_moist_stress_clm45default(bounds, & ! ! !ARGUMENTS: implicit none - type(bounds_type) , intent(in) :: bounds !bounds integer , intent(in) :: nlevgrnd !number of vertical layers integer , intent(in) :: fn !number of filters integer , intent(in) :: filterp(:) !filter array - real(r8) , intent(in) :: rootfr_unf(bounds%begp: , 1: ) + real(r8) , intent(in) :: rootfr_unf(: , : ) type(energyflux_type) , intent(inout) :: energyflux_vars type(soilstate_type) , intent(inout) :: soilstate_vars ! ! !LOCAL VARIABLES: real(r8), parameter :: btran0 = 0.0_r8 ! initial value real(r8) :: smp_node, s_node !temporary variables - real(r8) :: smp_node_lf !temporary variable + real(r8) :: smp_node_lf,sum1, sum2 !temporary variable integer :: p, f, j, c, l !indices !------------------------------------------------------------------------------ @@ -360,7 +429,10 @@ subroutine calc_root_moist_stress_clm45default(bounds, & h2osoi_vol => col_ws%h2osoi_vol , & ! Input: [real(r8) (:,:) ] volumetric soil water (0<=h2osoi_vol<=watsat) [m3/m3] h2osoi_liqvol => col_ws%h2osoi_liqvol & ! Output: [real(r8) (:,:) ] liquid volumetric moisture, will be used for BeTR ) + + !$acc parallel loop independent gang default(present) do j = 1,nlevgrnd + !$acc loop vector independent private(p,c,l,s_node,smp_node ) do f = 1, fn p = filterp(f) c = veg_pp%column(p) @@ -383,30 +455,56 @@ subroutine calc_root_moist_stress_clm45default(bounds, & if (.not. (perchroot .or. perchroot_alt) ) then rootr(p,j) = rootfr(p,j)*rresis(p,j) else - rootr(p,j) = rootfr_unf(p,j)*rresis(p,j) + rootr(p,j) = rootfr_unf(f,j)*rresis(p,j) end if + endif - !it is possible to further separate out a btran function, but I will leave it for the moment, jyt - if( .not. use_hydrstress ) then - btran(p) = btran(p) + max(rootr(p,j),0._r8) - endif - - !smp_node_lf = max(smpsc(veg_pp%itype(p)), -sucsat(c,j)*(h2osoi_vol(c,j)/watsat(c,j))**(-bsw(c,j))) - s_node = h2osoi_vol(c,j)/watsat(c,j) - - !call soil_water_retention_curve%soil_suction(sucsat(c,j), s_node, bsw(c,j), smp_node_lf) - smp_node_lf = -sucsat(c,j)*s_node**( -bsw(c,j) ) + end do + end do - !smp_node_lf = -sucsat(c,j)*(h2osoi_vol(c,j)/watsat(c,j))**(-bsw(c,j)) - smp_node_lf = max(smpsc(veg_pp%itype(p)), smp_node_lf) - btran2(p) = btran2(p) +rootfr(p,j)*min((smp_node_lf - smpsc(veg_pp%itype(p))) / & - (smpso(veg_pp%itype(p)) - smpsc(veg_pp%itype(p))), 1._r8) - endif + !calculate btran and btran2 + if(.not. use_hydrstress) then + !$acc parallel loop independent gang worker default(present) private(p,c,sum1) + do f = 1, fn + p = filterp(f) + c = veg_pp%column(p) + sum1 = btran(p) + !$acc loop reduction(+:sum1) private(s_node,smp_node_lf) + do j = 1, nlevgrnd + if (.not. (h2osoi_liqvol(c,j) .le. 0._r8 .or. t_soisno(c,j) .le. tfrz + tc_stress)) then + sum1 = sum1 + max(rootr(p,j),0._r8) + end if + end do + btran(p) = sum1 end do + end if + + !$acc parallel loop independent gang worker default(present) private(p,c,sum2) + do f = 1, fn + p = filterp(f) + c = veg_pp%column(p) + sum2 = btran2(p) + !$acc loop reduction(+:sum2) private(s_node,smp_node_lf) + do j = 1,nlevgrnd + if (.not. (h2osoi_liqvol(c,j) .le. 0._r8 .or. t_soisno(c,j) .le. tfrz + tc_stress)) then + !smp_node_lf = max(smpsc(veg_pp%itype(p)), -sucsat(c,j)*(h2osoi_vol(c,j)/watsat(c,j))**(-bsw(c,j))) + s_node = h2osoi_vol(c,j)/watsat(c,j) + !call soil_water_retention_curve%soil_suction(sucsat(c,j), s_node, bsw(c,j), smp_node_lf) + smp_node_lf = -sucsat(c,j)*s_node**( -bsw(c,j) ) + !smp_node_lf = -sucsat(c,j)*(h2osoi_vol(c,j)/watsat(c,j))**(-bsw(c,j)) + smp_node_lf = max(smpsc(veg_pp%itype(p)), smp_node_lf) + sum2 = sum2 +rootfr(p,j)*min((smp_node_lf - smpsc(veg_pp%itype(p))) / & + (smpso(veg_pp%itype(p)) - smpsc(veg_pp%itype(p))), 1._r8) + end if + end do + btran2(p) = sum2 end do + !$acc wait ! Normalize root resistances to get layer contribution to ET + !$acc parallel loop independent gang default(present) do j = 1,nlevgrnd + !$acc loop vector independent private(p) do f = 1, fn p = filterp(f) if (btran(p) > btran0) then @@ -416,6 +514,7 @@ subroutine calc_root_moist_stress_clm45default(bounds, & end if end do end do + end associate end subroutine calc_root_moist_stress_clm45default @@ -428,7 +527,6 @@ subroutine calc_root_moist_stress(bounds, nlevgrnd, fn, filterp, & ! compute the root water stress using different approaches ! ! USES - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 use elm_varcon , only : tfrz !temperature where water freezes [K], this is taken as constant at the moment use decompMod , only : bounds_type @@ -447,13 +545,14 @@ subroutine calc_root_moist_stress(bounds, nlevgrnd, fn, filterp, & type(soilstate_type) , intent(inout) :: soilstate_vars ! ! !LOCAL VARIABLES: - integer :: p, f, j, c, l ! indices - real(r8) :: smp_node, s_node ! temporary variables - real(r8) :: rootfr_unf(bounds%begp:bounds%endp,1:nlevgrnd) ! Rootfraction defined for unfrozen layers only. + integer :: p, f, j, c, l ! indices + real(r8) :: smp_node, s_node ! temporary variables + real(r8) :: rootfr_unf(1:fn,1:nlevgrnd) ! Rootfraction defined for unfrozen layers only. !------------------------------------------------------------------------------ !define normalized rootfraction for unfrozen soil - rootfr_unf(bounds%begp:bounds%endp,1:nlevgrnd) = 0._r8 + rootfr_unf(1:fn,1:nlevgrnd) = 0._r8 + !$acc enter data copyin(rootfr_unf(1:fn,1:nlevgrnd)) call normalize_unfrozen_rootfr(bounds, & ubj = nlevgrnd, & @@ -461,7 +560,7 @@ subroutine calc_root_moist_stress(bounds, nlevgrnd, fn, filterp, & filterp = filterp, & canopystate_vars=canopystate_vars, & soilstate_vars=soilstate_vars, & - rootfr_unf=rootfr_unf(bounds%begp:bounds%endp,1:nlevgrnd)) + rootfr_unf=rootfr_unf(1:fn,1:nlevgrnd)) !suppose h2osoi_liq, eff_porosity are already computed somewhere else @@ -469,16 +568,17 @@ subroutine calc_root_moist_stress(bounds, nlevgrnd, fn, filterp, & !add other methods later case (moist_stress_clm_default) - call calc_root_moist_stress_clm45default(bounds, & + call calc_root_moist_stress_clm45default( & nlevgrnd = nlevgrnd, & fn = fn, & filterp = filterp, & energyflux_vars=energyflux_vars, & soilstate_vars=soilstate_vars, & - rootfr_unf=rootfr_unf(bounds%begp:bounds%endp,1:nlevgrnd)) + rootfr_unf=rootfr_unf(1:fn,1:nlevgrnd)) case default end select + !$acc exit data delete(rootfr_unf(:,:)) end subroutine calc_root_moist_stress diff --git a/components/elm/src/biogeophys/SoilStateType.F90 b/components/elm/src/biogeophys/SoilStateType.F90 index 6e8604f95709..a205e7a4f7eb 100644 --- a/components/elm/src/biogeophys/SoilStateType.F90 +++ b/components/elm/src/biogeophys/SoilStateType.F90 @@ -1234,7 +1234,6 @@ subroutine InitColdGhost(this, bounds_proc) end subroutine InitColdGhost #else - !------------------------------------------------------------------------ subroutine InitColdGhost(this, bounds_proc) ! diff --git a/components/elm/src/biogeophys/SoilTemperatureMod.F90 b/components/elm/src/biogeophys/SoilTemperatureMod.F90 index bea06e4e89eb..836eb8ae7da5 100644 --- a/components/elm/src/biogeophys/SoilTemperatureMod.F90 +++ b/components/elm/src/biogeophys/SoilTemperatureMod.F90 @@ -31,6 +31,7 @@ module SoilTemperatureMod use perf_mod, only: t_startf, t_stopf use ExternalModelConstants , only : EM_ID_PTM use ExternalModelConstants , only : EM_PTM_TBASED_SOLVE_STAGE + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv use ExternalModelInterfaceMod, only : EMI_Driver use shr_const_mod , only : SHR_CONST_PI use GridcellType , only : grc_pp @@ -40,6 +41,12 @@ module SoilTemperatureMod use TemperatureType , only : temperature_type use WaterfluxType , only : waterflux_type use elm_instMod , only : waterflux_vars, waterstate_vars, temperature_vars + + #ifdef _OPENACC + #define gpuflag 1 + #else + #define gpuflag 0 + #endif ! ! !PUBLIC TYPES: implicit none @@ -82,15 +89,14 @@ module SoilTemperatureMod public :: SetRHSVec_SnowUrbanNonRoad ! Sets up the RHS vector corresponding to snow layers for Urban columns that are sunwall, shadewall, and roof columns public :: SetRHSVec_SnowUrbanRoad ! Sets up the RHS vector corresponding to snow layers for Urban columns that are pervious, and impervious columns public :: SetRHSVec_SnowNonUrban ! Sets up the RHS vector corresponding to snow layers for Non-Urban columns - public :: SetRHSVec_StandingSurfaceWater ! Sets up the RHS vector corresponding to standing water layers for Urban+Non-Urban columns + !public :: SetRHSVec_StandingSurfaceWater ! Sets up the RHS vector corresponding to standing water layers for Urban+Non-Urban columns public :: SetRHSVec_Soil ! Sets up the RHS vector corresponding to soil layers for Urban+Non-Urban columns public :: SetRHSVec_SoilUrban ! Sets up the RHS vector corresponding to soil layers for Urban columns public :: SetRHSVec_SoilUrbanNonRoad ! Sets up the RHS vector corresponding to soil layers for Urban columns that are pervious, and impervious columns public :: SetRHSVec_SoilUrbanRoad ! Sets up the RHS vector corresponding to soil layers for Urban columns that are pervious, and impervious columns public :: SetRHSVec_SoilNonUrban ! Sets up the RHS vector corresponding to soil layers for Non-Urban columns - public :: SetRHSVec_Soil_StandingSurfaceWater ! Adds contribution from standing water in the RHS vector corresponding to soil layers + !public :: SetRHSVec_Soil_StandingSurfaceWater ! Adds contribution from standing water in the RHS vector corresponding to soil layers public :: SetMatrix ! Sets up the matrix for the numerical solution of temperature for snow/standing-water/soil - public :: AssembleMatrixFromSubmatrices ! Assemble the full matrix from submatrices. public :: SetMatrix_Snow ! Set up the matrix entries corresponding to snow layers for Urban+Non-Urban columns public :: SetMatrix_SnowUrban ! Set up the matrix entries corresponding to snow layers for Urban column public :: SetMatrix_SnowUrbanNonRoad ! Set up the matrix entries corresponding to snow layers for Urban column that are sunwall, shadewall, and roof columns @@ -99,7 +105,6 @@ module SoilTemperatureMod public :: SetMatrix_Snow_Soil ! Set up the matrix entries corresponding to snow-soil interaction public :: SetMatrix_Snow_SoilUrban ! Set up the matrix entries corresponding to snow-soil interaction for Urban column public :: SetMatrix_Snow_SoilUrbanNonRoad ! Set up the matrix entries corresponding to snow-soil interaction for Urban column that are sunwall, shadewall, and roof columns - public :: SetMatrix_Snow_SoilUrbanRoad ! Set up the matrix entries corresponding to snow-soil interaction for Urban column that are pervious, and impervious columns public :: SetMatrix_Snow_SoilNonUrban ! Set up the matrix entries corresponding to snow-soil interaction for Non-Urban column public :: SetMatrix_Soil ! Set up the matrix entries corresponding to soil layers for Urban+Non-Urban columns public :: SetMatrix_SoilUrban ! Set up the matrix entries corresponding to soil layers for Urban column @@ -108,8 +113,6 @@ module SoilTemperatureMod public :: SetMatrix_SoilNonUrban ! Set up the matrix entries corresponding to soil layers for Non-Urban column public :: SetMatrix_Soil_Snow ! Set up the matrix entries corresponding to soil-snow interction for Urban+Non-Urban columns public :: SetMatrix_Soil_SnowUrban ! Set up the matrix entries corresponding to soil-snow interction for Urban column - public :: SetMatrix_Soil_SnowUrbanNonRoad ! Set up the matrix entries corresponding to soil-snow interction for Urban column that are sunwall, shadewall, and roof columns - public :: SetMatrix_Soil_SnowUrbanRoad ! Set up the matrix entries corresponding to soil-snow interction for Urban column that are pervious, and impervious columns public :: SetMatrix_Soil_SnowNonUrban ! Set up the matrix entries corresponding to soil-snow interction for Non-Urban column public :: SetMatrix_StandingSurfaceWater ! Set up the matrix entries corresponding to standing surface water public :: SetMatrix_StandingSurfaceWater_Soil ! Set up the matrix entries corresponding to standing surface water-soil interaction @@ -125,9 +128,6 @@ module SoilTemperatureMod integer :: thermal_model = default_thermal_model real(r8), private, parameter :: thin_sfclayer = 1.0e-6_r8 ! Threshold for thin surface layer !----------------------------------------------------------------------- - !$acc declare copyin(default_thermal_model) - !$acc declare copyin(petsc_thermal_model ) - !$acc declare create(thermal_model) contains !----------------------------------------------------------------------- @@ -144,14 +144,13 @@ subroutine init_soil_temperature() else thermal_model = petsc_thermal_model endif - !$acc update device(thermal_model) end subroutine init_soil_temperature !----------------------------------------------------------------------- subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filter_nolakec, & - atm2lnd_vars, urbanparams_vars, canopystate_vars, & - solarabs_vars, soilstate_vars, energyflux_vars ) + urbanparams_vars, canopystate_vars, & + solarabs_vars, soilstate_vars ) ! ! !DESCRIPTION: ! Snow and soil temperatures including phase change @@ -173,14 +172,12 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! results in a tridiagonal system equation. ! ! !USES: - !$acc routine seq use elm_varpar , only : nlevsno, nlevgrnd, nlevurb use elm_varctl , only : iulog use elm_varcon , only : cnfac, cpice, cpliq, denh2o use landunit_varcon , only : istice, istice_mec, istsoil, istcrop use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv, icol_road_imperv use landunit_varcon , only : istwet, istice, istice_mec, istsoil, istcrop - use BandDiagonalMod , only : BandDiagonal ! ! !ARGUMENTS: @@ -189,12 +186,10 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points integer , intent(in) :: num_urbanl ! number of urban landunits in clump integer , intent(in) :: filter_urbanl(:) ! urban landunit filter - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(urbanparams_type) , intent(in) :: urbanparams_vars type(canopystate_type) , intent(in) :: canopystate_vars type(soilstate_type) , intent(inout) :: soilstate_vars type(solarabs_type) , intent(inout) :: solarabs_vars - type(energyflux_type) , intent(inout) :: energyflux_vars real(r8) :: dtime ! land model time step (sec) ! @@ -202,8 +197,7 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte integer :: j,c,l,g,pi ! indices integer :: fc ! lake filtered column indices integer :: fl ! urban filtered landunit indices - integer :: jtop(bounds%begc:bounds%endc) ! top level at each column - real(r8) :: cv (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! heat capacity [J/(m2 K)] + real(r8) :: cv (1:num_nolakec,-nlevsno+1:nlevgrnd) ! heat capacity [J/(m2 K)] real(r8) :: tk (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! thermal conductivity [W/(m K)] real(r8) :: fn (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! heat diffusion through the layer interface [W/m2] real(r8) :: fn1(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! heat diffusion through the layer interface [W/m2] @@ -214,7 +208,6 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte real(r8) :: hs_top(bounds%begc:bounds%endc) ! net energy flux into surface layer (col) [W/m2] logical :: cool_on(bounds%begl:bounds%endl) ! is urban air conditioning on? logical :: heat_on(bounds%begl:bounds%endl) ! is urban heating on? - real(r8) :: fn_h2osfc(bounds%begc:bounds%endc) ! heat diffusion through standing-water/soil interface [W/m2] real(r8) :: dz_h2osfc(bounds%begc:bounds%endc) ! height of standing surface water [m] real(r8) :: tvector_nourbanc(bounds%begc:bounds%endc,-nlevsno:nlevgrnd) ! initial temperature solution for non-urban columns [Kelvin] real(r8) :: tvector_urbanc(bounds%begc:bounds%endc,-nlevsno:nlevgrnd) ! initial temperature solution for urban columns [Kelvin] @@ -227,11 +220,14 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte integer :: num_nolakec_and_nourbanc integer :: num_nolakec_and_urbanc integer :: num_filter_lun - integer, allocatable :: filter_nolakec_and_nourbanc(:) - integer, allocatable :: filter_nolakec_and_urbanc(:) + integer :: fnlu, fnlnu + integer :: fidx1, fidx2 + integer :: filter_nolakec_and_nourbanc(1:num_nolakec) + integer :: filter_nolakec_and_urbanc(1:num_nolakec) integer, allocatable :: filter_lun(:) logical :: urban_column logical :: update_temperature + real(r8) :: sum1, sum2 !----------------------------------------------------------------------- associate( & @@ -298,10 +294,20 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! Get step size - dtime = dtime_mod !get_step_size() + dtime = dtime_mod - ! Restrict internal building temperature to between min and max - ! and determine if heating or air conditioning is on + !$acc enter data create(cool_on(:), & + !$acc heat_on(:), jbot(:), & + !$acc fn(:,:), & + !$acc fn1(:,:),& + !$acc hs_top(:),dz_h2osfc(:), & + !$acc dhsdT(:), hs_soil(:),& + !$acc hs_top_snow(:),& + !$acc hs_h2osfc(:),& + !$acc sabg_lyr_col(:,:) , & + !$acc tk(:,:), cv(:,:) ) + + !$acc parallel loop independent gang vector default(present) do fl = 1,num_urbanl l = filter_urbanl(fl) if (lun_pp%urbpoi(l)) then @@ -321,10 +327,9 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! set up compact matrix for band diagonal solver, requires additional ! sub/super diagonals (1 each), and one additional row for t_h2osfc - jtop = -9999 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) - jtop(c) = snl(c) ! compute jbot if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & .or. col_pp%itype(c) == icol_roof) ) then @@ -338,42 +343,44 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! Setup two new filters: ! - filter_nolakec_and_nourbanc: No Lakes + No Urban columns ! - filter_nolakec_and_urbanc : No Lakes + Urban columns - ! - num_nolakec_and_nourbanc = 0 - num_nolakec_and_urbanc = 0 - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then - num_nolakec_and_urbanc = num_nolakec_and_urbanc + 1 - else - num_nolakec_and_nourbanc = num_nolakec_and_nourbanc + 1 - endif - enddo - - allocate(filter_nolakec_and_nourbanc(num_nolakec_and_nourbanc)) - allocate(filter_nolakec_and_urbanc( num_nolakec_and_urbanc )) - + ! + filter_nolakec_and_nourbanc (:) = 0 + filter_nolakec_and_urbanc (:) = 0 + !$acc enter data copyin(filter_nolakec_and_nourbanc(1:num_nolakec),& + !$acc filter_nolakec_and_urbanc(1:num_nolakec) ) + num_nolakec_and_nourbanc = 0 num_nolakec_and_urbanc = 0 + fnlu = 0 + fnlnu = 0 + !$acc parallel loop independent gang vector default(present) private(fidx1,fidx2,c,l) copy(fnlu,fnlnu) & + !$acc present(filter_nolakec_and_nourbanc(:), filter_nolakec_and_urbanc(:)) num_gangs(1) vector_length(1) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) if (lun_pp%urbpoi(l)) then - num_nolakec_and_urbanc = num_nolakec_and_urbanc + 1 - filter_nolakec_and_urbanc(num_nolakec_and_urbanc) = c + !$acc atomic capture + fnlu = fnlu + 1 + fidx1 = fnlu + !$acc end atomic + filter_nolakec_and_urbanc(fidx1) = c else - num_nolakec_and_nourbanc = num_nolakec_and_nourbanc + 1 - filter_nolakec_and_nourbanc(num_nolakec_and_nourbanc) = c + !$acc atomic capture + fnlnu = fnlnu + 1 + fidx2 = fnlnu + !$acc end atomic + filter_nolakec_and_nourbanc(fidx2) = c endif end do + num_nolakec_and_urbanc = fnlu + num_nolakec_and_nourbanc = fnlnu num_filter_lun = bounds%endl - bounds%begl + 1 allocate(filter_lun(num_filter_lun)) + do fc = 1, num_filter_lun filter_lun(fc) = bounds%begl + fc - 1 enddo - !------------------------------------------------------ ! Compute ground surface and soil temperatures !------------------------------------------------------ @@ -381,9 +388,10 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! Thermal conductivity and Heat capacity tk_h2osfc(begc:endc) = spval + !$acc enter data copyin(tk_h2osfc(:) ) call SoilThermProp(bounds, num_nolakec, filter_nolakec, & tk(begc:endc, :), & - cv(begc:endc, :), & + cv(1:, :), & tk_h2osfc(begc:endc), & urbanparams_vars, soilstate_vars) @@ -398,38 +406,41 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte hs_top( begc:endc ), & dhsdT( begc:endc ), & sabg_lyr_col( begc:endc, -nlevsno+1: ), & - atm2lnd_vars, urbanparams_vars, canopystate_vars, & - solarabs_vars, energyflux_vars) + urbanparams_vars, canopystate_vars, & + solarabs_vars) ! Determine heat diffusion through the layer interface and factor used in computing ! banded diagonal matrix and set up vector r and vectors a, b, c that define banded ! diagonal matrix and solve system call ComputeHeatDiffFluxAndFactor(bounds, num_nolakec, filter_nolakec, & - dtime, & + dtime_mod, & tk( begc:endc, -nlevsno+1: ), & - cv( begc:endc, -nlevsno+1: ), & + cv( 1:, -nlevsno+1: ), & fn( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - energyflux_vars) + fact( begc:endc, -nlevsno+1: ) ) ! compute thermal properties of h2osfc + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec - c = filter_nolakec(fc) - if ( (h2osfc(c) > thin_sfclayer) .and. (frac_h2osfc(c) > thin_sfclayer) ) then - c_h2osfc(c) = max(thin_sfclayer, cpliq*h2osfc(c)/frac_h2osfc(c) ) - dz_h2osfc(c) = max(thin_sfclayer, 1.0e-3*h2osfc(c)/frac_h2osfc(c) ) - else - c_h2osfc(c) = thin_sfclayer - dz_h2osfc(c) = thin_sfclayer - endif + c = filter_nolakec(fc) + if ( (h2osfc(c) > thin_sfclayer) .and. (frac_h2osfc(c) > thin_sfclayer) ) then + c_h2osfc(c) = max(thin_sfclayer, cpliq*h2osfc(c)/frac_h2osfc(c) ) + dz_h2osfc(c) = max(thin_sfclayer, 1.0e-3*h2osfc(c)/frac_h2osfc(c) ) + else + c_h2osfc(c) = thin_sfclayer + dz_h2osfc(c) = thin_sfclayer + endif enddo - + + ! initialize initial temperature vector - tvector_nourbanc(begc:endc, :) = spval tvector_urbanc( begc:endc, :) = spval + !$acc enter data copyin(tvector_nourbanc(:,:), tvector_urbanc(:,:)) + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) do j = snl(c)+1, 0 @@ -445,11 +456,9 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte tvector_urbanc(c,1:nlevgrnd) = t_soisno(c,1:nlevgrnd) enddo - ! ! Solve temperature for non-lake + non-urban columns ! - update_temperature = .true. select case(thermal_model) case (default_thermal_model) @@ -458,7 +467,7 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte call SolveTemperature(bounds, & num_nolakec_and_nourbanc, & filter_nolakec_and_nourbanc, & - dtime, & + dtime_mod, & hs_h2osfc( begc:endc ), & hs_top_snow( begc:endc ), & hs_soil( begc:endc ), & @@ -471,7 +480,7 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte fn( begc:endc, -nlevsno+1: ), & c_h2osfc( begc:endc ), & dz_h2osfc( begc:endc ), & - jtop( begc:endc ), & + snl( begc:endc ), & jbot( begc:endc ), & urban_column, & tvector_nourbanc( begc:endc, -nlevsno: )) @@ -486,20 +495,18 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte dhsdT( begc:endc ), & hs_soil( begc:endc ), & hs_top_snow( begc:endc ), & - hs_h2osfc( begc:endc ), & - energyflux_vars & + hs_h2osfc( begc:endc ) & ) call EMI_Driver(EM_ID_PTM, & EM_PTM_TBASED_SOLVE_STAGE, & - dt = dtime, & + dt = dtime_mod, & clump_rank = bounds%clump_index, & num_nolakec_and_nourbanc = num_nolakec_and_nourbanc, & filter_nolakec_and_nourbanc = filter_nolakec_and_nourbanc, & num_filter_lun = num_filter_lun, & filter_lun = filter_lun, & waterstate_vars = waterstate_vars, & - energyflux_vars = energyflux_vars, & temperature_vars = temperature_vars) #endif end select @@ -507,12 +514,12 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! ! Solve temperature for lake + urban column ! - + !$acc enter data copyin(update_temperature) urban_column = .true. call SolveTemperature(bounds, & num_nolakec_and_urbanc, & filter_nolakec_and_urbanc, & - dtime, & + dtime_mod, & hs_h2osfc( begc:endc ), & hs_top_snow( begc:endc ), & hs_soil( begc:endc ), & @@ -525,22 +532,26 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte fn( begc:endc, -nlevsno+1: ), & c_h2osfc( begc:endc ), & dz_h2osfc( begc:endc ), & - jtop( begc:endc ), & + snl( begc:endc ), & jbot( begc:endc ), & urban_column, & tvector_urbanc( begc:endc, -nlevsno: )) ! return temperatures to original array - + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) if (lun_pp%urbpoi(l)) then + !$acc loop seq do j = snl(c)+1, 0 t_soisno(c,j) = tvector_urbanc(c,j-1) !snow layers end do - t_soisno(c,1:nlevgrnd) = tvector_urbanc(c,1:nlevgrnd) !soil layers + !$acc loop seq + do j = 1, nlevgrnd + t_soisno(c,j) = tvector_urbanc(c,j) !soil layers + end do if (frac_h2osfc(c) == 0._r8) then t_h2osfc(c) = t_soisno(c,1) @@ -551,10 +562,14 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte else if (update_temperature) then + !$acc loop seq do j = snl(c)+1, 0 t_soisno(c,j) = tvector_nourbanc(c,j-1) !snow layers end do - t_soisno(c,1:nlevgrnd) = tvector_nourbanc(c,1:nlevgrnd) !soil layers + !$acc loop seq + do j = 1, nlevgrnd + t_soisno(c,j) = tvector_nourbanc(c,j) !soil layers + end do if (frac_h2osfc(c) == 0._r8) then t_h2osfc(c) = t_soisno(c,1) @@ -562,13 +577,11 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte t_h2osfc(c) = tvector_nourbanc(c,0) !surface water endif endif - endif - enddo ! Melting or Freezing - + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1,nlevgrnd do fc = 1,num_nolakec c = filter_nolakec(fc) @@ -600,6 +613,7 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte end do end do + !$acc parallel loop independent gang vector default(present) present(fn1(:,:),fn(:,:)) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -623,18 +637,18 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte end do ! compute phase change of h2osfc - + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) - xmf_h2osfc(c) = 0. + xmf_h2osfc(c) = 0._r8 end do - call PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & - dhsdT(bounds%begc:bounds%endc), energyflux_vars,dtime ) + dhsdT(bounds%begc:bounds%endc), dtime_mod ) call Phasechange_beta (bounds, num_nolakec, filter_nolakec, & - dhsdT(bounds%begc:bounds%endc), soilstate_vars, energyflux_vars, dtime) + dhsdT(bounds%begc:bounds%endc), soilstate_vars, dtime_mod) + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) ! this expression will (should) work whether there is snow or not @@ -659,6 +673,7 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte ! Initialize soil heat content + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -670,7 +685,8 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte end do ! Calculate soil heat content and soil plus snow heat content - + !NOTE: Split into reduction loop + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1,nlevgrnd do fc = 1,num_nolakec c = filter_nolakec(fc) @@ -684,29 +700,44 @@ subroutine SoilTemperature(bounds, num_urbanl, filter_urbanl, num_nolakec, filte else if (j == nlevgrnd .and. (col_pp%is_soil(c) .or. col_pp%is_crop(c))) then eflx_fgr(c,j) = 0._r8 end if + end do + end do - if (.not. lun_pp%urbpoi(l)) then + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + sum1 = 0.0_r8 ; sum2 = 0.0_r8 + if (.not. lun_pp%urbpoi(l)) then + !$acc loop vector reduction(+:sum1,sum2) + do j = -nlevsno+1,nlevgrnd if (j >= snl(c)+1) then - hc_soisno(c) = hc_soisno(c) + cv(c,j)*t_soisno(c,j) / 1.e6_r8 + sum1 = sum1 + cv(fc,j)*t_soisno(c,j) / 1.e6_r8 endif if (j >= 1) then - hc_soi(c) = hc_soi(c) + cv(c,j)*t_soisno(c,j) / 1.e6_r8 + sum2 = sum2 + cv(fc,j)*t_soisno(c,j) / 1.e6_r8 end if - end if - end do + end do + hc_soisno(c) = hc_soisno(c) + sum1 + hc_soi(c) = hc_soi(c) + sum2 + end if end do - + ! Free up memory + !$acc exit data delete(cool_on(:),heat_on(:), jbot(:), & + !$acc filter_nolakec_and_nourbanc(:), filter_nolakec_and_urbanc(:), & + !$acc tk(:,:), cv(:,:), tk_h2osfc(:), & + !$acc tvector_nourbanc(:,:), tvector_urbanc(:,:), fn(:,:), fn1(:,:), hs_top(:),dz_h2osfc(:), & + !$acc dhsdT(:), hs_soil(:), hs_top_snow(:), hs_h2osfc(:),sabg_lyr_col(:,:), & + !$acc update_temperature) + ! Free up memory - deallocate(filter_nolakec_and_nourbanc) - deallocate(filter_nolakec_and_urbanc ) deallocate(filter_lun ) end associate end subroutine SoilTemperature - !----------------------------------------------------------------------- subroutine SolveTemperature(bounds, num_filter, filter, dtime, & @@ -718,7 +749,6 @@ subroutine SolveTemperature(bounds, num_filter, filter, dtime, & ! Assembles and solves the banded penta-diagonal system of equations ! ! !USES: - !$acc routine seq use elm_varpar , only : nlevsno, nlevgrnd, nlevurb use elm_varctl , only : iulog use elm_varcon , only : cnfac, cpice, cpliq, denh2o @@ -729,29 +759,29 @@ subroutine SolveTemperature(bounds, num_filter, filter, dtime, & ! !ARGUMENTS: implicit none ! - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of columns in the filter - integer , intent(in) :: filter(:) ! column filter - real(r8) , intent(in) :: dtime ! land model time step (sec) - real(r8) , intent(in) :: hs_h2osfc( bounds%begc: ) ! heat flux on standing water [W/m2] - real(r8) , intent(in) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8) , intent(in) :: hs_soil( bounds%begc: ) ! heat flux on soil [W/m2] - real(r8) , intent(in) :: hs_top( bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8) , intent(in) :: dhsdT( bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8) , intent(in) :: sabg_lyr_col( bounds%begc: , -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8) , intent(in) :: tk( bounds%begc: , -nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8) , intent(in) :: tk_h2osfc( bounds%begc: ) ! thermal conductivity of h2osfc [W/(m K)] [col] - real(r8) , intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8) , intent(in) :: fn( bounds%begc: , -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8) , intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8) , intent(in) :: dz_h2osfc( bounds%begc: ) ! Thickness of standing water [m] - integer , intent(in) :: jtop(bounds%begc: ) ! top level at each column - integer , intent(in) :: jbot(bounds%begc: ) ! bottom level at each column - logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8) , intent(inout) :: tvector( bounds%begc: , -nlevsno: ) ! Numerical solution of temperature + type(bounds_type) , intent(in) :: bounds ! bounds + integer , intent(in) :: num_filter ! number of columns in the filter + integer , intent(in) :: filter(:) ! column filter + real(r8) , intent(in) :: dtime ! land model time step (sec) + real(r8) , intent(in) :: hs_h2osfc ( bounds%begc: ) ! heat flux on standing water [W/m2] + real(r8) , intent(in) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] + real(r8) , intent(in) :: hs_soil( bounds%begc: ) ! heat flux on soil [W/m2] + real(r8) , intent(in) :: hs_top ( bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] + real(r8) , intent(in) :: dhsdT ( bounds%begc: ) ! temperature derivative of "hs" [col] + real(r8) , intent(in) :: sabg_lyr_col( bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] + real(r8) , intent(in) :: tk( bounds%begc: , -nlevsno+1: ) ! thermal conductivity [W/(m K)] + real(r8) , intent(in) :: tk_h2osfc( bounds%begc: ) ! thermal conductivity of h2osfc [W/(m K)] [col] + real(r8) , intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] + real(r8) , intent(in) :: fn( bounds%begc: , -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] + real(r8) , intent(in) :: c_h2osfc ( bounds%begc: ) ! heat capacity of surface water [col] + real(r8) , intent(in) :: dz_h2osfc( bounds%begc: ) ! Thickness of standing water [m] + integer , intent(in) :: jtop(bounds%begc: ) ! top level at each column + integer , intent(in) :: jbot(bounds%begc: ) ! bottom level at each column + logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false + real(r8) , intent(inout) :: tvector( bounds%begc: , -nlevsno: ) ! Numerical solution of temperature ! ! !LOCAL VARIABLES: - integer :: c, fc, j + integer :: c, fc, j, l integer, parameter :: nband=5 real(r8) :: bmatrix(bounds%begc:bounds%endc,nband,-nlevsno:nlevgrnd) ! banded matrix for numerical solution of temperature real(r8) :: rvector(bounds%begc:bounds%endc,-nlevsno:nlevgrnd) ! RHS vector for numerical solution of temperature @@ -764,6 +794,22 @@ subroutine SolveTemperature(bounds, num_filter, filter, dtime, & ) ! Enforce expected array sizes + !$acc enter data create(rvector(:,:), bmatrix(:,:,:) ) + !$acc parallel loop independent collapse(2) gang vector default(present) + do j=-nlevsno, nlevgrnd + do c = begc, endc + rvector(c,j) = spval + end do + end do + + !$acc parallel loop independent default(present) collapse(3) + do j = -nlevsno,nlevgrnd + do l = 1,nband + do c = begc, endc + bmatrix(c,l,j) = 0._r8 + end do + end do + end do call SetRHSVec(bounds, num_filter, filter, & dtime, & @@ -800,18 +846,20 @@ subroutine SolveTemperature(bounds, num_filter, filter, dtime, & ! Solve the system call t_startf('SoilTempBandDiag') call BandDiagonal(bounds, -nlevsno, nlevgrnd, jtop(begc:endc), jbot(begc:endc), & - num_filter, filter, nband, bmatrix(begc:endc, :, :), & + num_filter, filter, bmatrix(begc:endc, :, :), & rvector(begc:endc, :), tvector(begc:endc, :)) call t_stopf('SoilTempBandDiag') + !$acc exit data delete(rvector(:,:), bmatrix(:,:,:) ) + end associate end subroutine SolveTemperature - !----------------------------------------------------------------------- - subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & - tk, cv, tk_h2osfc, & - urbanparams_vars, soilstate_vars) +!----------------------------------------------------------------------- +subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & + tk, cv, tk_h2osfc, & + urbanparams_vars, soilstate_vars) ! ! !DESCRIPTION: @@ -829,7 +877,6 @@ subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & ! flux from the interface to the node j+1. ! ! !USES: - !$acc routine seq use elm_varpar , only : nlevsno, nlevgrnd, nlevurb, nlevsoi use elm_varcon , only : denh2o, denice, tfrz, tkwat, tkice, tkair, cpice, cpliq, thk_bedrock use landunit_varcon , only : istice, istice_mec, istwet @@ -840,7 +887,7 @@ subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points - real(r8) , intent(out) :: cv( bounds%begc: , -nlevsno+1: ) ! heat capacity [J/(m2 K) ] [col, lev] + real(r8) , intent(out) :: cv( 1: , -nlevsno+1: ) ! heat capacity [J/(m2 K) ] [col, lev] real(r8) , intent(out) :: tk( bounds%begc: , -nlevsno+1: ) ! thermal conductivity at the layer interface [W/(m K) ] [col, lev] real(r8) , intent(out) :: tk_h2osfc( bounds%begc: ) ! thermal conductivity of h2osfc [W/(m K) ] [col] type(urbanparams_type) , intent(in) :: urbanparams_vars @@ -856,72 +903,70 @@ subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & real(r8) :: satw ! relative total water content of soil. real(r8) :: zh2osfc real(r8), parameter :: rho_ice = 917._r8 + real(r8), parameter :: k_snw_tmps(5) = [ 223.0_r8, 248.0_r8, 263.0_r8, 268.0_r8, 273.0_r8 ] + real(r8), parameter :: k_snw_coe1(5) = [ 2.564_r8, 2.172_r8, 1.985_r8, 1.883_r8, 1.776_r8 ] + real(r8), parameter :: k_snw_coe2(5) = [ -0.059_r8, 0.015_r8, 0.073_r8, 0.107_r8, 0.147_r8 ] + real(r8), parameter :: k_snw_coe3(5) = [ 0.0205_r8, 0.0252_r8, 0.0336_r8, 0.0386_r8, 0.0455_r8 ] real(r8) :: k_snw_vals(5) - real(r8) :: k_snw_tmps(5) - real(r8) :: k_snw_coe1(5) - real(r8) :: k_snw_coe2(5) - real(r8) :: k_snw_coe3(5) - data k_snw_tmps(:) /223.0_r8, 248.0_r8, 263.0_r8, 268.0_r8, 273.0_r8/ - data k_snw_coe1(:) /2.564_r8, 2.172_r8, 1.985_r8, 1.883_r8, 1.776_r8/ - data k_snw_coe2(:) /-0.059_r8, 0.015_r8, 0.073_r8, 0.107_r8, 0.147_r8/ - data k_snw_coe3(:) /0.0205_r8, 0.0252_r8, 0.0336_r8, 0.0386_r8, 0.0455_r8/ !----------------------------------------------------------------------- call t_startf('SoilThermProp') associate( & - snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers - dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) - zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) - z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer thickness (m) - nlev2bed => col_pp%nlevbed , & ! Input: [integer (:) ] number of layers to bedrock - - nlev_improad => urbanparams_vars%nlev_improad , & ! Input: [integer (:) ] number of impervious road layers - tk_wall => urbanparams_vars%tk_wall , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban wall - tk_roof => urbanparams_vars%tk_roof , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban roof - tk_improad => urbanparams_vars%tk_improad , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban impervious road - cv_wall => urbanparams_vars%cv_wall , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban wall - cv_roof => urbanparams_vars%cv_roof , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban roof - cv_improad => urbanparams_vars%cv_improad , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban impervious road - - t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) - - frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fractional snow covered area - h2osfc => col_ws%h2osfc , & ! Input: [real(r8) (:) ] surface (mm H2O) - h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) - h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) - h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) - bw => col_ws%bw , & ! Output: [real(r8) (:,:) ] partial density of water in the snow pack (ice + liquid) [kg/m3] - - tkmg => soilstate_vars%tkmg_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, soil minerals [W/m-K] - tkdry => soilstate_vars%tkdry_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, dry soil (W/m/Kelvin) - csol => soilstate_vars%csol_col , & ! Input: [real(r8) (:,:) ] heat capacity, soil solids (J/m**3/Kelvin) - watsat => soilstate_vars%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) - tksatu => soilstate_vars%tksatu_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, saturated soil [W/m-K] - thk => soilstate_vars%thk_col & ! Output: [real(r8) (:,:) ] thermal conductivity of each layer [W/m-K] - ) - - ! Thermal conductivity of soil from Farouki (1981) - ! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB) - ! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol., - ! 41, 1011-1026. - - do j = -nlevsno+1,nlevgrnd - do fc = 1, num_nolakec - c = filter_nolakec(fc) - nlevbed = nlev2bed(c) - - ! Only examine levels from 1->nlevgrnd - if (j >= 1) then - l = col_pp%landunit(c) - if ((col_pp%itype(c) == icol_sunwall .OR. col_pp%itype(c) == icol_shadewall) .and. j <= nlevurb) then - thk(c,j) = tk_wall(l,j) - else if (col_pp%itype(c) == icol_roof .and. j <= nlevurb) then - thk(c,j) = tk_roof(l,j) - else if (col_pp%itype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then - thk(c,j) = tk_improad(l,j) - else if (lun_pp%itype(l) /= istwet .AND. lun_pp%itype(l) /= istice .AND. lun_pp%itype(l) /= istice_mec & - .AND. col_pp%itype(c) /= icol_sunwall .AND. col_pp%itype(c) /= icol_shadewall .AND. & - col_pp%itype(c) /= icol_roof) then + snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers + dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) + zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer thickness (m) + nlev2bed => col_pp%nlevbed , & ! Input: [integer (:) ] number of layers to bedrock + + nlev_improad => urbanparams_vars%nlev_improad , & ! Input: [integer (:) ] number of impervious road layers + tk_wall => urbanparams_vars%tk_wall , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban wall + tk_roof => urbanparams_vars%tk_roof , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban roof + tk_improad => urbanparams_vars%tk_improad , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban impervious road + cv_wall => urbanparams_vars%cv_wall , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban wall + cv_roof => urbanparams_vars%cv_roof , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban roof + cv_improad => urbanparams_vars%cv_improad , & ! Input: [real(r8) (:,:) ] thermal conductivity of urban impervious road + + t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + + frac_sno => col_ws%frac_sno_eff , & ! Input: [real(r8) (:) ] fractional snow covered area + h2osfc => col_ws%h2osfc , & ! Input: [real(r8) (:) ] surface (mm H2O) + h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) + h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) + h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) + bw => col_ws%bw , & ! Output: [real(r8) (:,:) ] partial density of water in the snow pack (ice + liquid) [kg/m3] + + tkmg => soilstate_vars%tkmg_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, soil minerals [W/m-K] + tkdry => soilstate_vars%tkdry_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, dry soil (W/m/Kelvin) + csol => soilstate_vars%csol_col , & ! Input: [real(r8) (:,:) ] heat capacity, soil solids (J/m**3/Kelvin) + watsat => soilstate_vars%watsat_col , & ! Input: [real(r8) (:,:) ] volumetric soil water at saturation (porosity) + tksatu => soilstate_vars%tksatu_col , & ! Input: [real(r8) (:,:) ] thermal conductivity, saturated soil [W/m-K] + thk => soilstate_vars%thk_col & ! Output: [real(r8) (:,:) ] thermal conductivity of each layer [W/m-K] + ) + + ! Thermal conductivity of soil from Farouki (1981) + ! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB) + ! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol., + ! 41, 1011-1026. + + !$acc parallel loop gang independent default(present) + do j = -nlevsno+1,nlevgrnd + !$acc loop vector independent + do fc = 1, num_nolakec + c = filter_nolakec(fc) + nlevbed = nlev2bed(c) + + ! Only examine levels from 1->nlevgrnd + if (j >= 1) then + l = col_pp%landunit(c) + if ((col_pp%itype(c) == icol_sunwall .OR. col_pp%itype(c) == icol_shadewall) .and. j <= nlevurb) then + thk(c,j) = tk_wall(l,j) + else if (col_pp%itype(c) == icol_roof .and. j <= nlevurb) then + thk(c,j) = tk_roof(l,j) + else if (col_pp%itype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then + thk(c,j) = tk_improad(l,j) + else if (lun_pp%itype(l) /= istwet .AND. lun_pp%itype(l) /= istice .AND. lun_pp%itype(l) /= istice_mec & + .AND. col_pp%itype(c) /= icol_sunwall .AND. col_pp%itype(c) /= icol_shadewall .AND. & + col_pp%itype(c) /= icol_roof) then satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j)) satw = min(1._r8, satw) @@ -952,141 +997,156 @@ subroutine SoilThermProp (bounds, num_nolakec, filter_nolakec, & endif endif - if (use_T_rho_dependent_snowthk) then ! choose which snow thermal conductivity to use - if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then - bw(c,j) = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) / (frac_sno(c) * dz(c,j)) - - do i = 1, 5 - k_snw_vals(i) = k_snw_coe1(i) * (bw(c,j) / rho_ice)**2 - k_snw_coe2(i) * (bw(c,j) / rho_ice) + k_snw_coe3(i) - end do - - do i = 1, size(k_snw_tmps) - 1 - if (k_snw_tmps(i) <= t_soisno(c,j) .and. t_soisno(c,j) <= k_snw_tmps(i + 1)) then - thk(c,j) = k_snw_vals(i) + (t_soisno(c,j) - k_snw_tmps(i)) * (k_snw_vals(i + 1)-k_snw_vals(i)) / (k_snw_tmps(i + 1) - k_snw_tmps(i)) - end if - end do - - ! Handle edge cases if t_soisno(c,j) is outside the given range - if (t_soisno(c,j) < k_snw_tmps(1)) then - thk(c,j) = k_snw_vals(1) - else if (t_soisno(c,j) > k_snw_tmps(size(k_snw_tmps))) then - thk(c,j) = k_snw_vals(size(k_snw_tmps)) - end if - - end if - - - else - ! Thermal conductivity of snow, which from Jordan (1991) pp. 18 - ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 - if (snl(c) + 1 < 1 .AND. (j >= snl(c) + 1) .AND. (j <= 0)) then - bw(c,j) = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) / (frac_sno(c) * dz(c,j)) - thk(c,j) = tkair + (7.75e-5_r8 * bw(c,j) + 1.105e-6_r8 * bw(c,j) * bw(c,j)) * (tkice - tkair) - end if - endif end do end do - ! Thermal conductivity at the layer interface - + if (use_T_rho_dependent_snowthk) then ! choose which snow thermal conductivity to use + !$acc enter data create(k_snw_vals(:)) + !$acc parallel loop gang vector independent collapse(2) default(present) do j = -nlevsno+1,nlevgrnd - do fc = 1,num_nolakec + do fc = 1, num_nolakec c = filter_nolakec(fc) - if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & - .or. col_pp%itype(c) == icol_roof) .and. j <= nlevurb) then - if (j >= snl(c)+1 .AND. j <= nlevurb-1) then - tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & - /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) - else if (j == nlevurb) then - - ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across - ! the bottom "soil" layer and the equations are derived assuming a prescribed internal - ! building temperature. (See Oleson urban notes of 6/18/03). - tk(c,j) = thk(c,j) - end if - else if (col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & - .and. col_pp%itype(c) /= icol_roof) then - if (j >= snl(c)+1 .AND. j <= nlevgrnd-1) then - tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & - /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) - else if (j == nlevgrnd) then - tk(c,j) = 0._r8 - end if - end if - end do - end do - - ! calculate thermal conductivity of h2osfc - do fc = 1, num_nolakec - c = filter_nolakec(fc) - zh2osfc=1.0e-3*(0.5*h2osfc(c)) !convert to [m] from [mm] - tk_h2osfc(c)= tkwat*thk(c,1)*(z(c,1)+zh2osfc) & - /(tkwat*z(c,1)+thk(c,1)*zh2osfc) - enddo + if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then + bw(c,j) = (h2osoi_ice(c,j) + h2osoi_liq(c,j)) / (frac_sno(c) * dz(c,j)) + + !$acc loop seq + do i = 1, 5 + k_snw_vals(i) = k_snw_coe1(i) * (bw(c,j) / rho_ice)**2 - k_snw_coe2(i) * (bw(c,j) / rho_ice) + k_snw_coe3(i) + end do + + !$acc loop seq + do i = 1, size(k_snw_tmps) - 1 + if (k_snw_tmps(i) <= t_soisno(c,j) .and. t_soisno(c,j) <= k_snw_tmps(i + 1)) then + thk(c,j) = k_snw_vals(i) + (t_soisno(c,j) - k_snw_tmps(i)) * (k_snw_vals(i + 1)-k_snw_vals(i)) / (k_snw_tmps(i + 1) - k_snw_tmps(i)) + end if + end do - ! Soil heat capacity, from de Vires (1963) - ! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB) - ! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol., - ! 41, 1011-1026. + ! Handle edge cases if t_soisno(c,j) is outside the given range + if (t_soisno(c,j) < k_snw_tmps(1)) then + thk(c,j) = k_snw_vals(1) + else if (t_soisno(c,j) > k_snw_tmps(size(k_snw_tmps))) then + thk(c,j) = k_snw_vals(size(k_snw_tmps)) + end if - do j = 1, nlevgrnd - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - nlevbed = nlev2bed(c) - if ((col_pp%itype(c) == icol_sunwall .OR. col_pp%itype(c) == icol_shadewall) .and. j <= nlevurb) then - cv(c,j) = cv_wall(l,j) * dz(c,j) - else if (col_pp%itype(c) == icol_roof .and. j <= nlevurb) then - cv(c,j) = cv_roof(l,j) * dz(c,j) - else if (col_pp%itype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then - cv(c,j) = cv_improad(l,j) * dz(c,j) - else if (lun_pp%itype(l) /= istwet .AND. lun_pp%itype(l) /= istice .AND. lun_pp%itype(l) /= istice_mec & - .AND. col_pp%itype(c) /= icol_sunwall .AND. col_pp%itype(c) /= icol_shadewall .AND. & - col_pp%itype(c) /= icol_roof) then - cv(c,j) = csol(c,j)*(1._r8-watsat(c,j))*dz(c,j) + (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) - else if (lun_pp%itype(l) == istwet) then - cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) - if (j > nlevbed) cv(c,j) = csol(c,j)*dz(c,j) - else if (lun_pp%itype(l) == istice .OR. lun_pp%itype(l) == istice_mec) then - cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) - endif - if (j == 1) then - if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then - cv(c,j) = cv(c,j) + cpice*h2osno(c) - end if end if - enddo - end do - ! Snow heat capacity - - do j = -nlevsno+1,0 - do fc = 1,num_nolakec + end do + end do + !$acc exit data delete(k_snw_vals(:)) + else + !$acc parallel loop gang vector independent collapse(2) default(present) + do j = -nlevsno+1,nlevgrnd + do fc = 1, num_nolakec c = filter_nolakec(fc) - if (snl(c)+1 < 1 .and. j >= snl(c)+1) then - if (frac_sno(c) > 0._r8) then - cv(c,j) = max(thin_sfclayer, (cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j))/frac_sno(c)) - else - cv(c,j) = thin_sfclayer - end if + ! Thermal conductivity of snow, which from Jordan (1991) pp. 18 + ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1 + if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then + bw(c,j) = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/(frac_sno(c)*dz(c,j)) + thk(c,j) = tkair + (7.75e-5_r8 *bw(c,j) + 1.105e-6_r8*bw(c,j)*bw(c,j))*(tkice-tkair) end if - end do + end do end do - call t_stopf('SoilThermProp') - - end associate - - end subroutine SoilThermProp - +end if + + ! Thermal conductivity at the layer interface + !$acc parallel loop independent gang vector collapse(2) default(present) + do j = -nlevsno+1,nlevgrnd + do fc = 1,num_nolakec + c = filter_nolakec(fc) + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof) .and. j <= nlevurb) then + if (j >= snl(c)+1 .AND. j <= nlevurb-1) then + tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & + /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) + else if (j == nlevurb) then + + ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across + ! the bottom "soil" layer and the equations are derived assuming a prescribed internal + ! building temperature. (See Oleson urban notes of 6/18/03). + tk(c,j) = thk(c,j) + end if + else if (col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & + .and. col_pp%itype(c) /= icol_roof) then + if (j >= snl(c)+1 .AND. j <= nlevgrnd-1) then + tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) & + /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j))) + else if (j == nlevgrnd) then + tk(c,j) = 0._r8 + end if + end if + end do + end do + + ! calculate thermal conductivity of h2osfc + !$acc parallel loop independent gang vector default(present) private(c,zh2osfc) + do fc = 1, num_nolakec + c = filter_nolakec(fc) + zh2osfc=1.0e-3*(0.5*h2osfc(c)) !convert to [m] from [mm] + tk_h2osfc(c)= tkwat*thk(c,1)*(z(c,1)+zh2osfc) & + /(tkwat*z(c,1)+thk(c,1)*zh2osfc) + enddo + + ! Soil heat capacity, from de Vires (1963) + ! Urban values are from Masson et al. 2002, Evaluation of the Town Energy Balance (TEB) + ! scheme with direct measurements from dry districts in two cities, J. Appl. Meteorol., + ! 41, 1011-1026. + !$acc parallel loop gang vector collapse(2) independent default(present) + do j = 1, nlevgrnd + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + nlevbed = nlev2bed(c) + if ((col_pp%itype(c) == icol_sunwall .OR. col_pp%itype(c) == icol_shadewall) .and. j <= nlevurb) then + cv(fc,j) = cv_wall(l,j) * dz(c,j) + else if (col_pp%itype(c) == icol_roof .and. j <= nlevurb) then + cv(fc,j) = cv_roof(l,j) * dz(c,j) + else if (col_pp%itype(c) == icol_road_imperv .and. j >= 1 .and. j <= nlev_improad(l)) then + cv(fc,j) = cv_improad(l,j) * dz(c,j) + else if (lun_pp%itype(l) /= istwet .AND. lun_pp%itype(l) /= istice .AND. lun_pp%itype(l) /= istice_mec & + .AND. col_pp%itype(c) /= icol_sunwall .AND. col_pp%itype(c) /= icol_shadewall .AND. & + col_pp%itype(c) /= icol_roof) then + cv(fc,j) = csol(c,j)*(1._r8-watsat(c,j))*dz(c,j) + (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) + else if (lun_pp%itype(l) == istwet) then + cv(fc,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) + if (j > nlevbed) cv(fc,j) = csol(c,j)*dz(c,j) + else if (lun_pp%itype(l) == istice .OR. lun_pp%itype(l) == istice_mec) then + cv(fc,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq) + endif + if (j == 1) then + if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then + cv(fc,j) = cv(fc,j) + cpice*h2osno(c) + end if + end if + enddo + end do + + ! Snow heat capacity + !$acc parallel loop independent gang vector collapse(2) default(present) + do j = -nlevsno+1,0 + do fc = 1,num_nolakec + c = filter_nolakec(fc) + if (snl(c)+1 < 1 .and. j >= snl(c)+1) then + if (frac_sno(c) > 0._r8) then + cv(fc,j) = max(thin_sfclayer, (cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j))/frac_sno(c)) + else + cv(fc,j) = thin_sfclayer + end if + end if + end do + end do + call t_stopf('SoilThermProp') + +end associate + +end subroutine SoilThermProp !----------------------------------------------------------------------- subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & - dhsdT, energyflux_vars, dtime) + dhsdT, dtime) ! ! !DESCRIPTION: ! Only freezing is considered. When water freezes, move ice to bottom snow layer. ! ! !USES: - !$acc routine seq use elm_varcon , only : tfrz, hfus, grav, denice, cnfac, cpice, cpliq use elm_varpar , only : nlevsno, nlevgrnd use elm_varctl , only : iulog @@ -1096,18 +1156,17 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points real(r8) , intent(in) :: dhsdT ( bounds%begc: ) ! temperature derivative of "hs" [col ] - type(energyflux_type) , intent(inout) :: energyflux_vars real(r8), intent(in) :: dtime !land model time step (sec) ! ! !LOCAL VARIABLES: - integer :: j,c,g !do loop index - integer :: fc !lake filtered column indices - real(r8) :: temp1 !temporary variables [kg/m2 ] - real(r8) :: hm(bounds%begc:bounds%endc) !energy residual [W/m2 ] - real(r8) :: xm(bounds%begc:bounds%endc) !melting or freezing within a time step [kg/m2 ] - real(r8) :: tinc !t(n+1)-t(n) (K) - real(r8) :: smp !frozen water potential (mm) + integer :: j,c,g !do loop index + integer :: fc !lake filtered column indices + real(r8) :: temp1 !temporary variables [kg/m2 ] + real(r8) :: hm !energy residual [W/m2 ] + real(r8) :: xm !melting or freezing within a time step [kg/m2 ] + real(r8) :: tinc !t(n+1)-t(n) (K) + real(r8) :: smp !frozen water potential (mm) real(r8) :: rho_avg real(r8) :: z_avg real(r8) :: c1 @@ -1141,33 +1200,27 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & ! Get step size - ! Initialization - + ! Freezing identification + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) - + xmf_h2osfc(c) = 0._r8 - hm(c) = 0._r8 - xm(c) = 0._r8 + hm = 0._r8 + xm = 0._r8 qflx_h2osfc_to_ice(c) = 0._r8 eflx_h2osfc_to_snow_col(c) = 0._r8 - end do - - ! Freezing identification - do fc = 1,num_nolakec - c = filter_nolakec(fc) - ! If liquid exists below melt point, freeze some to ice. if ( frac_h2osfc(c) > 0._r8 .AND. t_h2osfc(c) <= tfrz) then tinc = tfrz - t_h2osfc(c) t_h2osfc(c) = tfrz ! energy absorbed beyond freezing temperature - hm(c) = frac_h2osfc(c)*(dhsdT(c)*tinc - tinc*c_h2osfc(c)/dtime) + hm = frac_h2osfc(c)*(dhsdT(c)*tinc - tinc*c_h2osfc(c)/dtime) ! mass of water converted from liquid to ice - xm(c) = hm(c)*dtime/hfus - temp1 = h2osfc(c) + xm(c) + xm = hm*dtime/hfus + temp1 = h2osfc(c) + xm z_avg=frac_sno(c)*snow_depth(c) if (z_avg > 0._r8) then @@ -1180,16 +1233,16 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & if(temp1 >= 0._r8) then ! add some frozen water to snow column ! add ice to snow column - h2osno(c) = h2osno(c) - xm(c) - int_snow(c) = int_snow(c) - xm(c) + h2osno(c) = h2osno(c) - xm + int_snow(c) = int_snow(c) - xm - if(snl(c) < 0) h2osoi_ice(c,0) = h2osoi_ice(c,0) - xm(c) + if(snl(c) < 0) h2osoi_ice(c,0) = h2osoi_ice(c,0) - xm ! remove ice from h2osfc - h2osfc(c) = h2osfc(c) + xm(c) + h2osfc(c) = h2osfc(c) + xm - xmf_h2osfc(c) = hm(c) - qflx_h2osfc_to_ice(c) = -xm(c)/dtime + xmf_h2osfc(c) = hm + qflx_h2osfc_to_ice(c) = -xm/dtime ! update snow depth if (frac_sno(c) > 0 .and. snl(c) < 0) then @@ -1210,7 +1263,7 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & c1=frac_sno(c)/fact(c,0)*dtime end if if ( frac_h2osfc(c) /= 0.0_r8 )then - c2=(-cpliq*xm(c) - frac_h2osfc(c)*dhsdT(c)*dtime) + c2=(-cpliq*xm - frac_h2osfc(c)*dhsdT(c)*dtime) else c2=0.0_r8 end if @@ -1239,7 +1292,7 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & ! cool frozen h2osfc layer with extra heat t_h2osfc(c) = t_h2osfc(c) - temp1*hfus/(dtime*dhsdT(c) - c_h2osfc(c)) - xmf_h2osfc(c) = (hm(c) - frac_h2osfc(c)*temp1*hfus/dtime) + xmf_h2osfc(c) = (hm - frac_h2osfc(c)*temp1*hfus/dtime) ! next, determine equilibrium temperature of combined ice/snow layer if (snl(c) == 0) then @@ -1281,7 +1334,7 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & endif endif - endif + endif enddo call t_stopf('PhaseChangeH2osfc') @@ -1289,56 +1342,55 @@ subroutine PhaseChangeH2osfc (bounds, num_nolakec, filter_nolakec, & end subroutine PhaseChangeH2osfc - !----------------------------------------------------------------------- + +!----------------------------------------------------------------------- subroutine Phasechange_beta (bounds, num_nolakec, filter_nolakec, dhsdT, & - soilstate_vars, energyflux_vars, dtime) - ! - ! !DESCRIPTION: - ! Calculation of the phase change within snow and soil layers: - ! (1) Check the conditions for which the phase change may take place, - ! i.e., the layer temperature is great than the freezing point - ! and the ice mass is not equal to zero (i.e. melting), - ! or the layer temperature is less than the freezing point - ! and the liquid water mass is greater than the allowable supercooled - ! liquid water calculated from freezing point depression (i.e. freezing). - ! (2) Assess the rate of phase change from the energy excess (or deficit) - ! after setting the layer temperature to freezing point. - ! (3) Re-adjust the ice and liquid mass, and the layer temperature - ! - ! !USES: - !$acc routine seq - use elm_varpar , only : nlevsno, nlevgrnd,nlevurb - use elm_varctl , only : iulog - use elm_varcon , only : tfrz, hfus, grav - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv - use landunit_varcon , only : istsoil, istcrop, istice_mec,istice - ! - ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter - integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points - real(r8) , intent(in) :: dhsdT ( bounds%begc: ) ! temperature derivative of "hs" [col] - type(soilstate_type) , intent(in) :: soilstate_vars - type(energyflux_type) , intent(inout) :: energyflux_vars - real(r8), intent(in) :: dtime !land model time step (sec) + soilstate_vars, dtime) + ! + ! !DESCRIPTION: + ! Calculation of the phase change within snow and soil layers: + ! (1) Check the conditions for which the phase change may take place, + ! i.e., the layer temperature is great than the freezing point + ! and the ice mass is not equal to zero (i.e. melting), + ! or the layer temperature is less than the freezing point + ! and the liquid water mass is greater than the allowable supercooled + ! liquid water calculated from freezing point depression (i.e. freezing). + ! (2) Assess the rate of phase change from the energy excess (or deficit) + ! after setting the layer temperature to freezing point. + ! (3) Re-adjust the ice and liquid mass, and the layer temperature + ! + ! !USES: + use elm_varpar , only : nlevsno, nlevgrnd,nlevurb + use elm_varctl , only : iulog + use elm_varcon , only : tfrz, hfus, grav + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall, icol_road_perv + use landunit_varcon , only : istsoil, istcrop, istice_mec + ! + ! !ARGUMENTS: + type(bounds_type) , intent(in) :: bounds + integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter + integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points + real(r8) , intent(in) :: dhsdT ( bounds%begc: ) ! temperature derivative of "hs" [col] + type(soilstate_type) , intent(in) :: soilstate_vars + real(r8), intent(in) :: dtime !land model time step (sec) + + ! + ! !LOCAL VARIABLES: + integer :: j,c,g,l !do loop index + integer :: fc !lake filtered column indices + real(r8) :: heatr !energy residual or loss after melting or freezing + real(r8) :: temp1 !temporary variables [kg/m2] + real(r8) :: hm !energy residual [W/m2] + real(r8) :: xm !melting or freezing within a time step [kg/m2] + real(r8) :: wmass0 !initial mass of ice and liquid (kg/m2) + real(r8) :: wice0 !initial mass of ice (kg/m2) + real(r8) :: supercool(num_nolakec,nlevgrnd) !supercooled water in soil (kg/m2) + real(r8) :: propor !proportionality constant (-) + real(r8) :: tinc(num_nolakec,-nlevsno+1:nlevgrnd) !t(n+1)-t(n) (K) + real(r8) :: smp !frozen water potential (mm) + real(r8) :: sum1,sum2 + !----------------------------------------------------------------------- - ! - ! !LOCAL VARIABLES: - integer :: j,c,g,l !do loop index - integer :: fc !lake filtered column indices - real(r8) :: heatr !energy residual or loss after melting or freezing - real(r8) :: temp1 !temporary variables [kg/m2] - real(r8) :: hm(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) !energy residual [W/m2] - real(r8) :: xm(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) !melting or freezing within a time step [kg/m2] - real(r8) :: wmass0(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd)!initial mass of ice and liquid (kg/m2) - real(r8) :: wice0 (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd)!initial mass of ice (kg/m2) - real(r8) :: wliq0 (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd)!initial mass of liquid (kg/m2) - real(r8) :: supercool(bounds%begc:bounds%endc,nlevgrnd) !supercooled water in soil (kg/m2) - real(r8) :: propor !proportionality constant (-) - real(r8) :: tinc(bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) !t(n+1)-t(n) (K) - real(r8) :: smp !frozen water potential (mm) - - !----------------------------------------------------------------------- call t_startf('PhaseChangebeta') associate( & @@ -1367,336 +1419,333 @@ subroutine Phasechange_beta (bounds, num_nolakec, filter_nolakec, dhsdT, & qflx_snomelt => col_wf%qflx_snomelt , & ! Output: [real(r8) (:) ] snow melt (mm H2O /s) qflx_snomelt_lyr => col_wf%qflx_snomelt_lyr , & ! Output: [real(r8) (:) ] snow melt (mm H2O /s) - eflx_snomelt => col_ef%eflx_snomelt , & ! Output: [real(r8) (:) ] snow melt heat flux (W/m**2) - eflx_snomelt_r => col_ef%eflx_snomelt_r , & ! Output: [real(r8) (:) ] rural snow melt heat flux (W/m**2) - eflx_snomelt_u => col_ef%eflx_snomelt_u , & ! Output: [real(r8) (:) ] urban snow melt heat flux (W/m**2) - - xmf => col_ef%xmf , & - fact => col_es%fact , & - - imelt => col_ef%imelt , & ! Output: [integer (:,:) ] flag for melting (=1), freezing (=2), Not=0 (new) - t_soisno => col_es%t_soisno & ! Output: [real(r8) (:,:) ] soil temperature (Kelvin) - ) - - ! Initialization - - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - - qflx_snomelt(c) = 0._r8 - qflx_snomelt_lyr(c,-nlevsno+1:0) = 0._r8 - xmf(c) = 0._r8 - qflx_snofrz_lyr(c,-nlevsno+1:0) = 0._r8 - qflx_snofrz_col(c) = 0._r8 - qflx_glcice_melt(c) = 0._r8 - qflx_glcice_melt_diag(c) = 0._r8 - qflx_snow_melt(c) = 0._r8 - end do - - do j = -nlevsno+1,nlevgrnd ! all layers - do fc = 1,num_nolakec - c = filter_nolakec(fc) - if (j >= snl(c)+1) then - - ! Initialization - imelt(c,j) = 0 - hm(c,j) = 0._r8 - xm(c,j) = 0._r8 - wice0(c,j) = h2osoi_ice(c,j) - wliq0(c,j) = h2osoi_liq(c,j) - wmass0(c,j) = h2osoi_ice(c,j) + h2osoi_liq(c,j) - endif ! end of snow layer if-block - end do ! end of column-loop - enddo ! end of level-loop - - !-- snow layers --------------------------------------------------- - do j = -nlevsno+1,0 - do fc = 1,num_nolakec - c = filter_nolakec(fc) - if (j >= snl(c)+1) then - - ! Melting identification - ! If ice exists above melt point, melt some to liquid. - if (h2osoi_ice(c,j) > 0._r8 .AND. t_soisno(c,j) > tfrz) then - imelt(c,j) = 1 - ! tinc(c,j) = t_soisno(c,j) - tfrz - tinc(c,j) = tfrz - t_soisno(c,j) - t_soisno(c,j) = tfrz - endif - - ! Freezing identification - ! If liquid exists below melt point, freeze some to ice. - if (h2osoi_liq(c,j) > 0._r8 .AND. t_soisno(c,j) < tfrz) then - imelt(c,j) = 2 - ! tinc(c,j) = t_soisno(c,j) - tfrz - tinc(c,j) = tfrz - t_soisno(c,j) - t_soisno(c,j) = tfrz - endif - endif ! end of snow layer if-block - end do ! end of column-loop - enddo ! end of level-loop - - !-- soil layers --------------------------------------------------- - do j = 1,nlevgrnd - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - supercool(c,j) = 0.0_r8 - ! add in urban condition if-block - if ((col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & - .and. col_pp%itype(c) /= icol_roof) .or. ( j <= nlevurb)) then - - - - if (h2osoi_ice(c,j) > 0. .AND. t_soisno(c,j) > tfrz) then - imelt(c,j) = 1 - ! tinc(c,j) = t_soisno(c,j) - tfrz - tinc(c,j) = tfrz - t_soisno(c,j) - t_soisno(c,j) = tfrz - endif - - ! from Zhao (1997) and Koren (1999) - supercool(c,j) = 0.0_r8 - if (col_pp%is_soil(c) .or. col_pp%is_crop(c) .or. col_pp%itype(c) == icol_road_perv) then - if(t_soisno(c,j) < tfrz) then - smp = hfus*(tfrz-t_soisno(c,j))/(grav*t_soisno(c,j)) * 1000._r8 !(mm) - supercool(c,j) = watsat(c,j)*(smp/sucsat(c,j))**(-1._r8/bsw(c,j)) - supercool(c,j) = supercool(c,j)*dz(c,j)*1000._r8 ! (mm) - endif - endif - - if (h2osoi_liq(c,j) > supercool(c,j) .AND. t_soisno(c,j) < tfrz) then - imelt(c,j) = 2 - ! tinc(c,j) = t_soisno(c,j) - tfrz - tinc(c,j) = tfrz - t_soisno(c,j) - t_soisno(c,j) = tfrz - endif - - ! If snow exists, but its thickness is less than the critical value (0.01 m) - if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. j == 1) then - if (t_soisno(c,j) > tfrz) then - imelt(c,j) = 1 - ! tincc,j) = t_soisno(c,j) - tfrz - tinc(c,j) = tfrz - t_soisno(c,j) - t_soisno(c,j) = tfrz - endif - endif - - endif - - end do - enddo - - - do j = -nlevsno+1,nlevgrnd ! all layers - do fc = 1,num_nolakec - c = filter_nolakec(fc) - - if ((col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & - .and. col_pp%itype(c) /= icol_roof) .or. ( j <= nlevurb)) then - - if (j >= snl(c)+1) then - - ! Calculate the energy surplus and loss for melting and freezing - if (imelt(c,j) > 0) then - - ! added unique cases for this calculation, - ! to account for absorbed solar radiation in each layer - - !================================================================== - if (j == snl(c)+1) then ! top layer - if(j > 0) then - hm(c,j) = dhsdT(c)*tinc(c,j) - tinc(c,j)/fact(c,j) - else - hm(c,j) = frac_sno_eff(c)*(dhsdT(c)*tinc(c,j) - tinc(c,j)/fact(c,j)) - endif - - if ( j==1 .and. frac_h2osfc(c) /= 0.0_r8 ) then - hm(c,j) = hm(c,j) - frac_h2osfc(c)*(dhsdT(c)*tinc(c,j)) - end if - else if (j == 1) then - hm(c,j) = (1.0_r8 - frac_sno_eff(c) - frac_h2osfc(c)) & - *dhsdT(c)*tinc(c,j) - tinc(c,j)/fact(c,j) - else ! non-interfacial snow/soil layers - if(j < 1) then - hm(c,j) = - frac_sno_eff(c)*(tinc(c,j)/fact(c,j)) - else - hm(c,j) = - tinc(c,j)/fact(c,j) - endif - endif - endif - - ! These two errors were checked carefully (Y. Dai). They result from the - ! computed error of "Tridiagonal-Matrix" in subroutine "thermal". - if (imelt(c,j) == 1 .AND. hm(c,j) < 0._r8) then - hm(c,j) = 0._r8 - imelt(c,j) = 0 - endif - if (imelt(c,j) == 2 .AND. hm(c,j) > 0._r8) then - hm(c,j) = 0._r8 - imelt(c,j) = 0 - endif - - ! The rate of melting and freezing - - if (imelt(c,j) > 0 .and. abs(hm(c,j)) > 0._r8) then - xm(c,j) = hm(c,j)*dtime/hfus ! kg/m2 - - ! If snow exists, but its thickness is less than the critical value - ! (1 cm). Note: more work is needed to determine how to tune the - ! snow depth for this case - if (j == 1) then - if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. xm(c,j) > 0._r8) then - temp1 = h2osno(c) ! kg/m2 - h2osno(c) = max(0._r8,temp1-xm(c,j)) - propor = h2osno(c)/temp1 - snow_depth(c) = propor * snow_depth(c) - heatr = hm(c,j) - hfus*(temp1-h2osno(c))/dtime ! W/m2 - if (heatr > 0._r8) then - xm(c,j) = heatr*dtime/hfus ! kg/m2 - hm(c,j) = heatr ! W/m2 - else - xm(c,j) = 0._r8 - hm(c,j) = 0._r8 - endif - qflx_snomelt(c) = max(0._r8,(temp1-h2osno(c)))/dtime ! kg/(m2 s) - xmf(c) = hfus*qflx_snomelt(c) - qflx_snow_melt(c) = qflx_snomelt(c) - endif - endif - - heatr = 0._r8 - if (xm(c,j) > 0._r8) then - h2osoi_ice(c,j) = max(0._r8, wice0(c,j)-xm(c,j)) - heatr = hm(c,j) - hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime - else if (xm(c,j) < 0._r8) then - if (j <= 0) then - h2osoi_ice(c,j) = min(wmass0(c,j), wice0(c,j)-xm(c,j)) ! snow - else - if (wmass0(c,j) < supercool(c,j)) then - h2osoi_ice(c,j) = 0._r8 - else - h2osoi_ice(c,j) = min(wmass0(c,j) - supercool(c,j),wice0(c,j)-xm(c,j)) - endif - endif - heatr = hm(c,j) - hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime - endif - - h2osoi_liq(c,j) = max(0._r8,wmass0(c,j)-h2osoi_ice(c,j)) - - if (abs(heatr) > 0._r8) then - if (j == snl(c)+1) then - - if(j==1) then - t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr & - /(1._r8-(1.0_r8 - frac_h2osfc(c))*fact(c,j)*dhsdT(c)) - else - t_soisno(c,j) = t_soisno(c,j) + (fact(c,j)/frac_sno_eff(c))*heatr & - /(1._r8-fact(c,j)*dhsdT(c)) - endif - - else if (j == 1) then - - t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr & - /(1._r8-(1.0_r8 - frac_sno_eff(c) - frac_h2osfc(c))*fact(c,j)*dhsdT(c)) - else - if(j > 0) then - t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr - else - if(frac_sno_eff(c) > 0._r8) t_soisno(c,j) = t_soisno(c,j) + (fact(c,j)/frac_sno_eff(c))*heatr - endif - endif - - if (j <= 0) then ! snow - if (h2osoi_liq(c,j)*h2osoi_ice(c,j)>0._r8) t_soisno(c,j) = tfrz - end if - endif ! end of heatr > 0 if-block - - if (j >= 1) then - xmf(c) = xmf(c) + hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime - else - xmf(c) = xmf(c) + hfus*(wice0(c,j)-h2osoi_ice(c,j))/dtime - endif - - if (imelt(c,j) == 1 .AND. j < 1) then - qflx_snomelt(c) = qflx_snomelt(c) + max(0._r8,(wice0(c,j)-h2osoi_ice(c,j)))/dtime - qflx_snomelt_lyr(c,j) = max(0._r8,(wice0(c,j)-h2osoi_ice(c,j)))/dtime - - endif - - ! layer freezing mass flux (positive): - if (imelt(c,j) == 2 .AND. j < 1) then - qflx_snofrz_lyr(c,j) = max(0._r8,(h2osoi_ice(c,j)-wice0(c,j)))/dtime - endif - - endif - - endif ! end of snow layer if-block - - endif - - ! For glacier_mec columns, compute negative ice flux from melted ice. - ! Note that qflx_glcice can also include a positive component from excess snow, - ! as computed in HydrologyDrainageMod.F90. - - l = col_pp%landunit(c) - if ( lun_pp%itype(l) == istice_mec) then - if (j>=1 .and. h2osoi_liq(c,j) > 0._r8) then ! ice layer with meltwater - ! melting corresponds to a negative ice flux - qflx_glcice_melt(c) = qflx_glcice_melt(c) + h2osoi_liq(c,j)/dtime - qflx_glcice(c) = qflx_glcice(c) - h2osoi_liq(c,j)/dtime - - ! convert layer back to pure ice by "borrowing" ice from below the column - h2osoi_ice(c,j) = h2osoi_ice(c,j) + h2osoi_liq(c,j) - h2osoi_liq(c,j) = 0._r8 - - endif ! liquid water is present - endif ! istice_mec - ! for diagnostic QICE SMB output only - - ! these are to calculate SMB even without MECs - if ( lun_pp%itype(l) == istice) then - if (j>=1 .and. h2osoi_liq(c,j) > 0._r8) then ! ice layer with meltwater - ! melting corresponds to a negative ice flux - qflx_glcice_melt_diag(c) = qflx_glcice_melt_diag(c) + h2osoi_liq(c,j)/dtime - qflx_glcice_diag(c) = qflx_glcice_diag(c) - h2osoi_liq(c,j)/dtime - endif ! liquid water is present - endif ! istice_mec - - - end do ! end of column-loop - enddo ! end of level-loop - - ! Needed for history file output - - do fc = 1,num_nolakec - c = filter_nolakec(fc) - eflx_snomelt(c) = qflx_snomelt(c) * hfus - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then - eflx_snomelt_u(c) = eflx_snomelt(c) - else if (col_pp%is_soil(c) .or. col_pp%is_crop(c)) then - eflx_snomelt_r(c) = eflx_snomelt(c) - end if - end do - - call t_stopf('PhaseChangebeta') - do j = -nlevsno+1,0 - do fc = 1,num_nolakec - c = filter_nolakec(fc) - qflx_snofrz_col(c) = qflx_snofrz_col(c) + qflx_snofrz_lyr(c,j) - end do - end do - - end associate - - end subroutine Phasechange_beta + eflx_snomelt => col_ef%eflx_snomelt , & ! Output: [real(r8) (:) ] snow melt heat flux (W/m**2) + eflx_snomelt_r => col_ef%eflx_snomelt_r , & ! Output: [real(r8) (:) ] rural snow melt heat flux (W/m**2) + eflx_snomelt_u => col_ef%eflx_snomelt_u , & ! Output: [real(r8) (:) ] urban snow melt heat flux (W/m**2) + + xmf => col_ef%xmf , & + fact => col_es%fact , & + + imelt => col_ef%imelt , & ! Output: [integer (:,:) ] flag for melting (=1), freezing (=2), Not=0 (new) + t_soisno => col_es%t_soisno & ! Output: [real(r8) (:,:) ] soil temperature (Kelvin) + ) + + ! Initialization + !$acc enter data create(supercool(:,:), tinc(:,:),sum1,sum2) + + !$acc parallel loop independent gang vector default(present) present(xmf(:)) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + + qflx_snomelt(c) = 0._r8 + xmf(c) = 0._r8 + qflx_snofrz_col(c) = 0._r8 + qflx_glcice_melt(c) = 0._r8 + qflx_glcice_melt_diag(c) = 0._r8 + qflx_snow_melt(c) = 0._r8 + end do + + !$acc parallel loop independent gang vector collapse(2) default(present) + do j = -nlevsno+1,nlevgrnd ! all layers + do fc = 1,num_nolakec + c = filter_nolakec(fc) + if (j >= snl(c)+1) then + imelt(c,j) = 0 + endif ! end of snow layer if-block + end do ! end of column-loop + enddo ! end of level-loop + + !-- snow layers --------------------------------------------------- + !$acc parallel loop independent collapse(2) gang vector default(present) + do j = -nlevsno+1,0 + do fc = 1,num_nolakec + c = filter_nolakec(fc) + qflx_snofrz_lyr(c,j) = 0._r8 + qflx_snomelt_lyr(c,j) = 0._r8 + + if (j >= snl(c)+1) then + ! Melting identification + ! If ice exists above melt point, melt some to liquid. + if (h2osoi_ice(c,j) > 0._r8 .AND. t_soisno(c,j) > tfrz) then + imelt(c,j) = 1 + ! tinc(c,j) = t_soisno(c,j) - tfrz + tinc(fc,j) = tfrz - t_soisno(c,j) + t_soisno(c,j) = tfrz + endif + + ! Freezing identification + ! If liquid exists below melt point, freeze some to ice. + if (h2osoi_liq(c,j) > 0._r8 .AND. t_soisno(c,j) < tfrz) then + imelt(c,j) = 2 + ! tinc(c,j) = t_soisno(c,j) - tfrz + tinc(fc,j) = tfrz - t_soisno(c,j) + t_soisno(c,j) = tfrz + endif + endif ! end of snow layer if-block + end do ! end of column-loop + enddo ! end of level-loop + + !-- soil layers --------------------------------------------------- + !$acc parallel loop independent gang vector collapse(2) default(present) + do j = 1,nlevgrnd + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + supercool(fc,j) = 0.0_r8 + ! add in urban condition if-block + if ((col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & + .and. col_pp%itype(c) /= icol_roof) .or. ( j <= nlevurb)) then + + if (h2osoi_ice(c,j) > 0. .AND. t_soisno(c,j) > tfrz) then + imelt(c,j) = 1 + ! tinc(c,j) = t_soisno(c,j) - tfrz + tinc(fc,j) = tfrz - t_soisno(c,j) + t_soisno(c,j) = tfrz + endif + + ! from Zhao (1997) and Koren (1999) + supercool(fc,j) = 0.0_r8 + if (lun_pp%itype(l) == istsoil .or. col_pp%is_crop(c) .or. col_pp%itype(c) == icol_road_perv) then + if(t_soisno(c,j) < tfrz) then + smp = hfus*(tfrz-t_soisno(c,j))/(grav*t_soisno(c,j)) * 1000._r8 !(mm) + supercool(fc,j) = watsat(c,j)*(smp/sucsat(c,j))**(-1._r8/bsw(c,j)) + supercool(fc,j) = supercool(fc,j)*dz(c,j)*1000._r8 ! (mm) + endif + endif + + if (h2osoi_liq(c,j) > supercool(fc,j) .AND. t_soisno(c,j) < tfrz) then + imelt(c,j) = 2 + ! tinc(c,j) = t_soisno(c,j) - tfrz + tinc(fc,j) = tfrz - t_soisno(c,j) + t_soisno(c,j) = tfrz + endif + + ! If snow exists, but its thickness is less than the critical value (0.01 m) + if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. j == 1) then + if (t_soisno(c,j) > tfrz) then + imelt(c,j) = 1 + ! tincc,j) = t_soisno(c,j) - tfrz + tinc(fc,j) = tfrz - t_soisno(c,j) + t_soisno(c,j) = tfrz + endif + endif + + endif + + end do + enddo + + !$acc parallel loop independent gang worker default(present) present(tinc(:,:), xmf(:) ) private(sum1,sum2) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1, sum2) + do j = -nlevsno+1,nlevgrnd ! all layers + hm = 0.0_r8 + xm = 0.0_r8 + wmass0 = h2osoi_ice(c,j) + h2osoi_liq(c,j) + wice0 = h2osoi_ice(c,j) + if ((col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & + .and. col_pp%itype(c) /= icol_roof) .or. ( j <= nlevurb)) then + + if (j >= snl(c)+1) then + + ! Calculate the energy surplus and loss for melting and freezing + if (imelt(c,j) > 0) then + + ! added unique cases for this calculation, + ! to account for absorbed solar radiation in each layer + !================================================================== + if (j == snl(c)+1) then ! top layer + if(j > 0) then + hm = dhsdT(c)*tinc(fc,j) - tinc(fc,j)/fact(c,j) + else + hm = frac_sno_eff(c)*(dhsdT(c)*tinc(fc,j) - tinc(fc,j)/fact(c,j)) + endif + + if ( j==1 .and. frac_h2osfc(c) /= 0.0_r8 ) then + hm = hm - frac_h2osfc(c)*(dhsdT(c)*tinc(fc,j)) + end if + else if (j == 1) then + hm = (1.0_r8 - frac_sno_eff(c) - frac_h2osfc(c)) & + *dhsdT(c)*tinc(fc,j) - tinc(fc,j)/fact(c,j) + else ! non-interfacial snow/soil layers + if(j < 1) then + hm = - frac_sno_eff(c)*(tinc(fc,j)/fact(c,j)) + else + hm = - tinc(fc,j)/fact(c,j) + endif + endif + endif + ! These two errors were checked carefully (Y. Dai). They result from the + ! computed error of "Tridiagonal-Matrix" in subroutine "thermal". + if (imelt(c,j) == 1 .AND. hm < 0._r8) then + hm = 0._r8 + imelt(c,j) = 0 + endif + if (imelt(c,j) == 2 .AND. hm > 0._r8) then + hm = 0._r8 + imelt(c,j) = 0 + endif + + ! The rate of melting and freezing + if (imelt(c,j) > 0 .and. abs(hm) > 0._r8) then + xm = hm * dtime/hfus ! kg/m2 + + ! If snow exists, but its thickness is less than the critical value + ! (1 cm). Note: more work is needed to determine how to tune the + ! snow depth for this case + if (j == 1) then + if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8 .AND. xm > 0._r8) then + temp1 = h2osno(c) ! kg/m2 + h2osno(c) = max(0._r8,temp1-xm) + propor = h2osno(c)/temp1 + snow_depth(c) = propor * snow_depth(c) + heatr = hm - hfus*(temp1-h2osno(c))/dtime ! W/m2 + if (heatr > 0._r8) then + xm = heatr*dtime/hfus ! kg/m2 + hm = heatr ! W/m2 + else + xm = 0._r8 + hm = 0._r8 + endif + qflx_snomelt(c) = max(0._r8,(temp1-h2osno(c)))/dtime ! kg/(m2 s) + xmf(c) = hfus*qflx_snomelt(c) + qflx_snow_melt(c) = qflx_snomelt(c) + endif + endif + heatr = 0._r8 + if (xm > 0._r8) then + h2osoi_ice(c,j) = max(0._r8, wice0-xm) + heatr = hm - hfus*(wice0-h2osoi_ice(c,j))/dtime + else if (xm < 0._r8) then + if (j <= 0) then + h2osoi_ice(c,j) = min(wmass0, wice0-xm) ! snow + else + if (wmass0 < supercool(fc,j)) then + h2osoi_ice(c,j) = 0._r8 + else + h2osoi_ice(c,j) = min(wmass0 - supercool(fc,j),wice0 - xm) + endif + endif + heatr = hm - hfus*(wice0 - h2osoi_ice(c,j))/dtime + endif + + h2osoi_liq(c,j) = max(0._r8,wmass0 - h2osoi_ice(c,j)) + + if (abs(heatr) > 0._r8) then + if (j == snl(c)+1) then + + if(j==1) then + t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr & + /(1._r8-(1.0_r8 - frac_h2osfc(c))*fact(c,j)*dhsdT(c)) + else + t_soisno(c,j) = t_soisno(c,j) + (fact(c,j)/frac_sno_eff(c))*heatr & + /(1._r8-fact(c,j)*dhsdT(c)) + endif + + else if (j == 1) then + + t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr & + /(1._r8-(1.0_r8 - frac_sno_eff(c) - frac_h2osfc(c))*fact(c,j)*dhsdT(c)) + else + if(j > 0) then + t_soisno(c,j) = t_soisno(c,j) + fact(c,j)*heatr + else + if(frac_sno_eff(c) > 0._r8) t_soisno(c,j) = t_soisno(c,j) + (fact(c,j)/frac_sno_eff(c))*heatr + endif + endif + + if (j <= 0) then ! snow + if (h2osoi_liq(c,j)*h2osoi_ice(c,j)>0._r8) t_soisno(c,j) = tfrz + end if + endif ! end of heatr > 0 if-block + + sum1 = sum1 + hfus*(wice0 - h2osoi_ice(c,j))/dtime + if (imelt(c,j) == 1 .AND. j < 1) then + ! qflx_snomelt(c) = qflx_snomelt(c) + max(0._r8,(wice0 - h2osoi_ice(c,j)))/dtime + sum2 = sum2 + max(0._r8,(wice0 - h2osoi_ice(c,j)))/dtime + endif + + ! layer freezing mass flux (positive): + if (imelt(c,j) == 2 .AND. j < 1) then + qflx_snofrz_lyr(c,j) = max(0._r8,(h2osoi_ice(c,j)-wice0 ))/dtime + endif + endif + endif ! end of snow layer if-block + endif + end do ! end of level-loop + xmf(c) = xmf(c) + sum1 + qflx_snomelt(c) = qflx_snomelt(c) + sum2 + enddo ! end of col-loop + + ! For glacier_mec columns, compute negative ice flux from melted ice. + ! Note that qflx_glcice can also include a positive component from excess snow, + ! as computed in HydrologyDrainageMod.F90. + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + sum1 = 0.0_r8 + sum2 = 0.0_r8 + !$acc loop vector reduction(+:sum1,sum2) + do j = -nlevsno+1,nlevgrnd ! all layers + if (lun_pp%itype(l)==istice_mec) then + if (j>=1 .and. h2osoi_liq(c,j) > 0._r8) then ! ice layer with meltwater + ! melting corresponds to a negative ice flux + sum1 = sum1 + h2osoi_liq(c,j)/dtime + sum2 = sum2 - h2osoi_liq(c,j)/dtime + + ! convert layer back to pure ice by "borrowing" ice from below the column + h2osoi_ice(c,j) = h2osoi_ice(c,j) + h2osoi_liq(c,j) + h2osoi_liq(c,j) = 0._r8 + + endif ! liquid water is present + endif ! istice_mec + enddo ! end of level-loop + qflx_glcice_melt(c) = qflx_glcice_melt(c) + sum1 + qflx_glcice(c) = qflx_glcice(c) + sum2 + end do ! end of column-loop + + ! Needed for history file output + + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + eflx_snomelt(c) = qflx_snomelt(c) * hfus + l = col_pp%landunit(c) + if (lun_pp%urbpoi(l)) then + eflx_snomelt_u(c) = eflx_snomelt(c) + else if (lun_pp%itype(l) == istsoil .or. lun_pp%itype(l) == istcrop) then + eflx_snomelt_r(c) = eflx_snomelt(c) + end if + end do + + !$acc parallel loop independent gang worker default(present) private(sum1) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + sum1 = 0.0_r8 + !$acc loop vector reduction(+:sum1) + do j = -nlevsno+1,0 + sum1 = sum1 + qflx_snofrz_lyr(c,j) + end do + qflx_snofrz_col(c) = qflx_snofrz_col(c) + sum1 + end do + + !$acc exit data delete(supercool(:,:), tinc(:,:), sum1,sum2 ) + call t_stopf('PhaseChangebeta') + +end associate + +end subroutine Phasechange_beta !----------------------------------------------------------------------- subroutine ComputeGroundHeatFluxAndDeriv(bounds, num_nolakec, filter_nolakec, & hs_h2osfc, hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, & - atm2lnd_vars, urbanparams_vars, canopystate_vars, & - solarabs_vars, energyflux_vars) + urbanparams_vars, canopystate_vars, & + solarabs_vars) ! ! !DESCRIPTION: ! Computes ground heat flux on: @@ -1707,7 +1756,6 @@ subroutine ComputeGroundHeatFluxAndDeriv(bounds, num_nolakec, filter_nolakec, & ! Additionally, derivative of ground heat flux w.r.t to temeprature ! ! !USES: - !$acc routine seq use elm_varcon , only : sb, hvap use column_varcon , only : icol_road_perv, icol_road_imperv use elm_varpar , only : nlevsno, max_patch_per_col @@ -1717,33 +1765,33 @@ subroutine ComputeGroundHeatFluxAndDeriv(bounds, num_nolakec, filter_nolakec, & type(bounds_type) , intent(in) :: bounds ! bounds integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec( : ) ! column filter for non-lake points - real(r8) , intent(out) :: hs_h2osfc( bounds%begc: ) ! heat flux on standing water [W/m2] - real(r8) , intent(out) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8) , intent(out) :: hs_soil( bounds%begc: ) ! heat flux on soil [W/m2] - real(r8) , intent(out) :: hs_top (bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8) , intent(out) :: dhsdT( bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8) , intent(out) :: sabg_lyr_col( bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - type(atm2lnd_type) , intent(in) :: atm2lnd_vars + real(r8) , intent(inout) :: hs_h2osfc( bounds%begc: ) ! heat flux on standing water [W/m2] + real(r8) , intent(inout) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] + real(r8) , intent(inout) :: hs_soil( bounds%begc: ) ! heat flux on soil [W/m2] + real(r8) , intent(inout) :: hs_top (bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] + real(r8) , intent(inout) :: dhsdT( bounds%begc: ) ! temperature derivative of "hs" [col] + real(r8) , intent(inout) :: sabg_lyr_col( bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] type(urbanparams_type) , intent(in) :: urbanparams_vars type(canopystate_type) , intent(in) :: canopystate_vars type(solarabs_type) , intent(inout) :: solarabs_vars - type(energyflux_type) , intent(inout) :: energyflux_vars ! ! !LOCAL VARIABLES: integer :: j,c,p,l,t,g,pi ! indices integer :: fc ! lake filtered column indices - real(r8) :: hs(bounds%begc:bounds%endc) ! net energy flux into the surface (w/m2) - real(r8) :: lwrad_emit(bounds%begc:bounds%endc) ! emitted longwave radiation - real(r8) :: dlwrad_emit(bounds%begc:bounds%endc) ! time derivative of emitted longwave radiation - integer :: lyr_top ! index of top layer of snowpack (-4 to 0) [idx] - real(r8) :: eflx_gnet_top ! net energy flux into surface layer, pft-level [W/m2] - real(r8) :: lwrad_emit_snow(bounds%begc:bounds%endc) ! - real(r8) :: lwrad_emit_soil(bounds%begc:bounds%endc) ! - real(r8) :: lwrad_emit_h2osfc(bounds%begc:bounds%endc) ! - real(r8) :: eflx_gnet_snow ! - real(r8) :: eflx_gnet_soil ! - real(r8) :: eflx_gnet_h2osfc ! - real(r8) :: slope_rad, deg2rad + real(r8) :: lwrad_emit(num_nolakec) ! emitted longwave radiation + real(r8) :: dlwrad_emit(num_nolakec) ! time derivative of emitted longwave radiation + integer :: lyr_top ! index of top layer of snowpack (-4 to 0) [idx] + real(r8) :: eflx_gnet_top ! net energy flux into surface layer, pft-level [W/m2] + real(r8) :: lwrad_emit_snow(num_nolakec) ! + real(r8) :: lwrad_emit_soil(num_nolakec) ! + real(r8) :: lwrad_emit_h2osfc(num_nolakec) ! + real(r8) :: eflx_gnet_snow ! + real(r8) :: eflx_gnet_soil ! + real(r8) :: eflx_gnet_h2osfc ! + real(r8) :: slope_rad + real(r8), parameter :: deg2rad = SHR_CONST_PI/180._r8 + real(r8) :: sum1,sum2,sum3 ! + integer :: begc, endc !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -1793,105 +1841,110 @@ subroutine ComputeGroundHeatFluxAndDeriv(bounds, num_nolakec, filter_nolakec, & sabg_chk => solarabs_vars%sabg_chk_patch , & ! Output: [real(r8) (:) ] sum of soil/snow using current fsno, for balance check sabg_lyr => solarabs_vars%sabg_lyr_patch , & ! Output: [real(r8) (:,:) ] absorbed solar radiation (pft,lyr) [W/m2] - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc , & ! Input: [integer ] ending column index slope_deg => grc_pp%slope_deg & ) ! Net ground heat flux into the surface and its temperature derivative ! Added a pfts loop here to get the average of hs and dhsdT over ! all PFTs on the column. Precalculate the terms that do not depend on PFT. - - do fc = 1,num_nolakec + + !$acc enter data create(lwrad_emit_snow(:), lwrad_emit_soil(:), & + !$acc lwrad_emit_h2osfc(:), lwrad_emit(:), dlwrad_emit(:) ) + begc = bounds%begc + endc = bounds%endc + !$acc parallel loop independent gang vector default(present) + do fc = 1, num_nolakec c = filter_nolakec(fc) - g = col_pp%gridcell(c) - l = col_pp%landunit(c) - lwrad_emit(c) = emg(c) * sb * t_grnd(c)**4 - dlwrad_emit(c) = 4._r8*emg(c) * sb * t_grnd(c)**3 + lwrad_emit(fc) = emg(c) * sb * t_grnd(c)**4 + dlwrad_emit(fc) = 4._r8*emg(c) * sb * t_grnd(c)**3 ! fractionate lwrad_emit; balanced in CanopyFluxes & Biogeophysics2 - lwrad_emit_snow(c) = emg(c) * sb * t_soisno(c,snl(c)+1)**4 - lwrad_emit_soil(c) = emg(c) * sb * t_soisno(c,1)**4 - lwrad_emit_h2osfc(c) = emg(c) * sb * t_h2osfc(c)**4 - + lwrad_emit_snow(fc) = emg(c) * sb * t_soisno(c,snl(c)+1)**4 + lwrad_emit_h2osfc(fc) = emg(c) * sb * t_h2osfc(c)**4 + lwrad_emit_soil(fc) = emg(c) * sb * t_soisno(c,1)**4 if (use_finetop_rad .and. (.not. lun_pp%urbpoi(l))) then - deg2rad = SHR_CONST_PI/180._r8 slope_rad = slope_deg(g) * deg2rad lwrad_emit(c) = lwrad_emit(c) / cos(slope_rad) dlwrad_emit(c) = dlwrad_emit(c) / cos(slope_rad) - lwrad_emit_snow(c) = lwrad_emit_snow(c) / cos(slope_rad) - lwrad_emit_soil(c) = lwrad_emit_soil(c) / cos(slope_rad) - lwrad_emit_h2osfc(c) = lwrad_emit_h2osfc(c) / cos(slope_rad) + lwrad_emit_snow(fc) = lwrad_emit_snow(fc) / cos(slope_rad) + lwrad_emit_soil(fc) = lwrad_emit_soil(fc) / cos(slope_rad) + lwrad_emit_h2osfc(fc) = lwrad_emit_h2osfc(fc) / cos(slope_rad) endif end do - hs_soil(begc:endc) = 0._r8 - hs_h2osfc(begc:endc) = 0._r8 - hs(begc:endc) = 0._r8 - dhsdT(begc:endc) = 0._r8 - do pi = 1,max_patch_per_col - do fc = 1,num_nolakec - c = filter_nolakec(fc) - if ( pi <= col_pp%npfts(c) ) then - p = col_pp%pfti(c) + pi - 1 - l = veg_pp%landunit(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) - - if (veg_pp%active(p)) then - if (.not. lun_pp%urbpoi(l)) then - eflx_gnet(p) = sabg(p) + dlrad(p) & - + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit(c) & - - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) - ! save sabg for balancecheck, in case frac_sno is set to zero later - sabg_chk(p) = frac_sno_eff(c) * sabg_snow(p) + (1._r8 - frac_sno_eff(c) ) * sabg_soil(p) - - eflx_gnet_snow = sabg_snow(p) + dlrad(p) & - + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_snow(c) & - - (eflx_sh_snow(p)+qflx_ev_snow(p)*htvp(c)) - - eflx_gnet_soil = sabg_soil(p) + dlrad(p) & - + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_soil(c) & - - (eflx_sh_soil(p)+qflx_ev_soil(p)*htvp(c)) - - eflx_gnet_h2osfc = sabg_soil(p) + dlrad(p) & - + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_h2osfc(c) & - - (eflx_sh_h2osfc(p)+qflx_ev_h2osfc(p)*htvp(c)) + !$acc parallel loop independent gang default(present) private(sum1,sum2,sum3) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + hs_soil(c) = 0._r8 + hs_h2osfc(c) = 0._r8 + dhsdT(c) = 0._r8 + sum1 = 0.0_r8; + sum2 = 0.0_r8; + sum3 = 0.0_r8; + !$acc loop vector independent reduction(+:sum1,sum2,sum3) + do p = col_pp%pfti(c), col_pp%pftf(c) + ! + l = veg_pp%landunit(p) + t = veg_pp%topounit(p) + g = veg_pp%gridcell(p) + + if (veg_pp%active(p)) then + if (.not. lun_pp%urbpoi(l)) then + eflx_gnet(p) = sabg(p) + dlrad(p) & + + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit(fc) & + - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) + ! save sabg for balancecheck, in case frac_sno is set to zero later + sabg_chk(p) = frac_sno_eff(c) * sabg_snow(p) + (1._r8 - frac_sno_eff(c) ) * sabg_soil(p) + + eflx_gnet_snow = sabg_snow(p) + dlrad(p) & + + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_snow(fc) & + - (eflx_sh_snow(p)+qflx_ev_snow(p)*htvp(c)) + + eflx_gnet_soil = sabg_soil(p) + dlrad(p) & + + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_soil(fc) & + - (eflx_sh_soil(p)+qflx_ev_soil(p)*htvp(c)) + + eflx_gnet_h2osfc = sabg_soil(p) + dlrad(p) & + + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) - lwrad_emit_h2osfc(fc) & + - (eflx_sh_h2osfc(p)+qflx_ev_h2osfc(p)*htvp(c)) + else + ! For urban columns we use the net longwave radiation (eflx_lwrad_net) because of + ! interactions between urban columns. + + ! All wasteheat and traffic flux goes into canyon floor + if (col_pp%itype(c) == icol_road_perv .or. col_pp%itype(c) == icol_road_imperv) then + eflx_wasteheat_patch(p) = eflx_wasteheat(l)/(1._r8-lun_pp%wtlunit_roof(l)) + eflx_heat_from_ac_patch(p) = eflx_heat_from_ac(l)/(1._r8-lun_pp%wtlunit_roof(l)) + eflx_traffic_patch(p) = eflx_traffic(l)/(1._r8-lun_pp%wtlunit_roof(l)) else - ! For urban columns we use the net longwave radiation (eflx_lwrad_net) because of - ! interactions between urban columns. - - ! All wasteheat and traffic flux goes into canyon floor - if (col_pp%itype(c) == icol_road_perv .or. col_pp%itype(c) == icol_road_imperv) then - eflx_wasteheat_patch(p) = eflx_wasteheat(l)/(1._r8-lun_pp%wtlunit_roof(l)) - eflx_heat_from_ac_patch(p) = eflx_heat_from_ac(l)/(1._r8-lun_pp%wtlunit_roof(l)) - eflx_traffic_patch(p) = eflx_traffic(l)/(1._r8-lun_pp%wtlunit_roof(l)) - else - eflx_wasteheat_patch(p) = 0._r8 - eflx_heat_from_ac_patch(p) = 0._r8 - eflx_traffic_patch(p) = 0._r8 - end if - ! Include transpiration term because needed for previous road - ! and include wasteheat and traffic flux - eflx_gnet(p) = sabg(p) + dlrad(p) & - - eflx_lwrad_net(p) & - - (eflx_sh_grnd(p) + qflx_evap_soi(p)*htvp(c) + qflx_tran_veg(p)*hvap) & - + eflx_wasteheat_patch(p) + eflx_heat_from_ac_patch(p) + eflx_traffic_patch(p) - eflx_anthro(p) = eflx_wasteheat_patch(p) + eflx_traffic_patch(p) - eflx_gnet_snow = eflx_gnet(p) - eflx_gnet_soil = eflx_gnet(p) - eflx_gnet_h2osfc = eflx_gnet(p) + eflx_wasteheat_patch(p) = 0._r8 + eflx_heat_from_ac_patch(p) = 0._r8 + eflx_traffic_patch(p) = 0._r8 end if - dgnetdT(p) = - cgrnd(p) - dlwrad_emit(c) - hs(c) = hs(c) + eflx_gnet(p) * veg_pp%wtcol(p) - dhsdT(c) = dhsdT(c) + dgnetdT(p) * veg_pp%wtcol(p) - ! separate surface fluxes for soil/snow - hs_soil(c) = hs_soil(c) + eflx_gnet_soil * veg_pp%wtcol(p) - hs_h2osfc(c) = hs_h2osfc(c) + eflx_gnet_h2osfc * veg_pp%wtcol(p) - + ! Include transpiration term because needed for previous road + ! and include wasteheat and traffic flux + eflx_gnet(p) = sabg(p) + dlrad(p) & + - eflx_lwrad_net(p) & + - (eflx_sh_grnd(p) + qflx_evap_soi(p)*htvp(c) + qflx_tran_veg(p)*hvap) & + + eflx_wasteheat_patch(p) + eflx_heat_from_ac_patch(p) + eflx_traffic_patch(p) + eflx_anthro(p) = eflx_wasteheat_patch(p) + eflx_traffic_patch(p) + eflx_gnet_snow = eflx_gnet(p) + eflx_gnet_soil = eflx_gnet(p) + eflx_gnet_h2osfc = eflx_gnet(p) end if + dgnetdT(p) = - cgrnd(p) - dlwrad_emit(fc) + sum1 = sum1 + dgnetdT(p) * veg_pp%wtcol(p) + + ! separate surface fluxes for soil/snow + sum2 = sum2 + eflx_gnet_soil * veg_pp%wtcol(p) + sum3 = sum3 + eflx_gnet_h2osfc * veg_pp%wtcol(p) + end if end do + !!! + dhsdT(c) = sum1; + hs_soil(c) = sum2; + hs_h2osfc(c) = sum3; end do ! Additional calculations with SNICAR: @@ -1902,150 +1955,182 @@ subroutine ComputeGroundHeatFluxAndDeriv(bounds, num_nolakec, filter_nolakec, & ! where S is absorbed radiation, and T is temperature. Now, ! assume delS/delT is zero, then it is OK to just add S ! to each layer - + ! Initialize: - sabg_lyr_col(begc:endc,-nlevsno+1:1) = 0._r8 - hs_top(begc:endc) = 0._r8 - hs_top_snow(begc:endc) = 0._r8 - - do pi = 1,max_patch_per_col - do fc = 1,num_nolakec - c = filter_nolakec(fc) - lyr_top = snl(c) + 1 - if ( pi <= col_pp%npfts(c) ) then - p = col_pp%pfti(c) + pi - 1 - if (veg_pp%active(p)) then - g = veg_pp%gridcell(p) - t = veg_pp%topounit(p) - l = veg_pp%landunit(p) - if (.not. lun_pp%urbpoi(l)) then - - eflx_gnet_top = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & - - lwrad_emit(c) - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) + ! hs_top(begc:endc) = 0._r8 + ! hs_top_snow(begc:endc) = 0._r8 - hs_top(c) = hs_top(c) + eflx_gnet_top*veg_pp%wtcol(p) - - eflx_gnet_snow = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & - - lwrad_emit_snow(c) - (eflx_sh_snow(p)+qflx_ev_snow(p)*htvp(c)) - - eflx_gnet_soil = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & - - lwrad_emit_soil(c) - (eflx_sh_soil(p)+qflx_ev_soil(p)*htvp(c)) + !$acc parallel loop independent gang default(present) private(sum1,sum2) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + lyr_top = snl(c) + 1 + ! + sum1 = 0.0_r8; sum2 = 0.0_r8; + !$acc loop vector independent reduction(+:sum1,sum2) + do p = col_pp%pfti(c), col_pp%pftf(c) + if (veg_pp%active(p)) then + g = veg_pp%gridcell(p) + t = veg_pp%topounit(p) + l = veg_pp%landunit(p) + if (.not. lun_pp%urbpoi(l)) then + eflx_gnet_top = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & + - lwrad_emit(fc) - (eflx_sh_grnd(p)+qflx_evap_soi(p)*htvp(c)) - hs_top_snow(c) = hs_top_snow(c) + eflx_gnet_snow*veg_pp%wtcol(p) + sum1 = sum1 + eflx_gnet_top*veg_pp%wtcol(p) - do j = lyr_top,1,1 - sabg_lyr_col(c,j) = sabg_lyr_col(c,j) + sabg_lyr(p,j) * veg_pp%wtcol(p) - enddo - else + eflx_gnet_snow = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & + - lwrad_emit_snow(fc) - (eflx_sh_snow(p)+qflx_ev_snow(p)*htvp(c)) - hs_top(c) = hs_top(c) + eflx_gnet(p)*veg_pp%wtcol(p) - hs_top_snow(c) = hs_top_snow(c) + eflx_gnet(p)*veg_pp%wtcol(p) - sabg_lyr_col(c,lyr_top) = sabg_lyr_col(c,lyr_top) + sabg(p) * veg_pp%wtcol(p) + eflx_gnet_soil = sabg_lyr(p,lyr_top) + dlrad(p) + (1._r8-frac_veg_nosno(p))*emg(c)*forc_lwrad(t) & + - lwrad_emit_soil(fc) - (eflx_sh_soil(p)+qflx_ev_soil(p)*htvp(c)) - endif + sum2 = sum2 + eflx_gnet_snow*veg_pp%wtcol(p) + + else + ! + sum1 = sum1 + eflx_gnet(p) * veg_pp%wtcol(p) + sum2 = sum2 + eflx_gnet(p) * veg_pp%wtcol(p) endif - endif enddo + hs_top(c) = sum1 + hs_top_snow(c) = sum2 enddo + ! sabg_lyr_col(begc:endc,-nlevsno+1:1) = 0._r8 + !$acc parallel loop independent gang worker default(present) private(sum3) collapse(2) + do j = -nlevsno,1,1 + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + lyr_top = snl(c) + 1 + if(j < lyr_top) cycle + sum3 = 0._r8 + if(.not. lun_pp%urbpoi(l)) then + !$acc loop vector reduction(+:sum3) + do p = col_pp%pfti(c), col_pp%pftf(c) + if(veg_pp%active(p)) then + sum3 = sum3 + sabg_lyr(p,j) * veg_pp%wtcol(p) + end if + enddo + sabg_lyr_col(c,j) = sum3 + end if + end do + end do + + !$acc parallel loop independent gang worker default(present) + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + lyr_top = snl(c) + 1 + sum3 = 0._r8 + if(lun_pp%urbpoi(l)) then + !$acc loop vector independent reduction(+:sum3) + do p = col_pp%pfti(c), col_pp%pftf(c) + if (veg_pp%active(p)) then + sum3 = sum3 + sabg(p) * veg_pp%wtcol(p) + end if + end do + sabg_lyr_col(c,lyr_top) = sum3 + end if + end do + !$acc exit data delete(lwrad_emit_snow(:), lwrad_emit_soil(:), & + !$acc lwrad_emit_h2osfc(:), lwrad_emit(:), dlwrad_emit(:) ) end associate end subroutine ComputeGroundHeatFluxAndDeriv !----------------------------------------------------------------------- subroutine ComputeHeatDiffFluxAndFactor(bounds, num_nolakec, filter_nolakec, dtime, & - tk, cv, fn, fact, & - energyflux_vars) - ! - ! !DESCRIPTION: - ! Computes: - ! (1) Heat diffusion at the interface of layers. - ! (2) Factor used in computing tridiagonal matrix - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : capr, cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type) , intent(in) :: bounds ! bounds - integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter - integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points - real(r8) , intent(in) :: dtime ! land model time step (sec) - real(r8) , intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8) , intent(in) :: cv (bounds%begc: ,-nlevsno+1: ) ! heat capacity [J/(m2 K)] - real(r8) , intent(out) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8) , intent(out) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - type(energyflux_type) , intent(in) :: energyflux_vars - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - real(r8) :: dzm ! used in computing tridiagonal matrix - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate(& - zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) - dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) - z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer thickness (m) - t_building => lun_es%t_building , & ! Input: [real(r8) (:) ] internal building temperature (K) - t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) - eflx_bot => col_ef%eflx_bot & ! Input: [real(r8) (:) ] heat flux from beneath column (W/m**2) [+ = upward] - ) - - ! Determine heat diffusion through the layer interface and factor used in computing - ! tridiagonal matrix and set up vector r and vectors a, b, c that define tridiagonal - ! matrix and solve system - - do j = -nlevsno+1,nlevgrnd - do fc = 1,num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & - .or. col_pp%itype(c) == icol_roof) .and. j <= nlevurb) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - fact(c,j) = dtime/cv(c,j) - fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) - else if (j <= nlevurb-1) then - fact(c,j) = dtime/cv(c,j) - fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) - dzm = (z(c,j)-z(c,j-1)) - else if (j == nlevurb) then - fact(c,j) = dtime/cv(c,j) - ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across - ! the bottom "soil" layer and the equations are derived assuming a prescribed internal - ! building temperature. (See Oleson urban notes of 6/18/03). - fn(c,j) = tk(c,j) * (t_building(l) - cnfac*t_soisno(c,j))/(zi(c,j) - z(c,j)) - end if - end if - else if (col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & - .and. col_pp%itype(c) /= icol_roof) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - fact(c,j) = dtime/cv(c,j) * dz(c,j) / (0.5_r8*(z(c,j)-zi(c,j-1)+capr*(z(c,j+1)-zi(c,j-1)))) - fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) - else if (j <= nlevgrnd-1) then - fact(c,j) = dtime/cv(c,j) - fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) - dzm = (z(c,j)-z(c,j-1)) - else if (j == nlevgrnd) then - fact(c,j) = dtime/cv(c,j) - fn(c,j) = eflx_bot(c) - end if - end if - end if - end do - end do - - end associate - - end subroutine ComputeHeatDiffFluxAndFactor + tk, cv, fn, fact ) +! +! !DESCRIPTION: +! Computes: +! (1) Heat diffusion at the interface of layers. +! (2) Factor used in computing tridiagonal matrix +! +! !USES: +use elm_varcon , only : capr, cnfac +use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type) , intent(in) :: bounds ! bounds +integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter +integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points +real(r8) , intent(in) :: dtime ! land model time step (sec) +real(r8) , intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] +real(r8) , intent(in) :: cv (1: ,-nlevsno+1: ) ! heat capacity [J/(m2 K)] +real(r8) , intent(inout) :: fn (bounds%begc:, -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8) , intent(inout) :: fact(bounds%begc:, -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +! +! LOCAL VARIABLES: +integer :: j,c,l ! indices +integer :: fc ! lake filtered column indices +real(r8) :: dzm ! used in computing tridiagonal matrix +!----------------------------------------------------------------------- +! Enforce expected array sizes +!----------------------------------------------------------------------- +associate(& + zi => col_pp%zi , & ! Input: [real(r8) (:,:) ] interface level below a "z" level (m) + dz => col_pp%dz , & ! Input: [real(r8) (:,:) ] layer depth (m) + z => col_pp%z , & ! Input: [real(r8) (:,:) ] layer thickness (m) + t_building => lun_es%t_building , & ! Input: [real(r8) (:) ] internal building temperature (K) + t_soisno => col_es%t_soisno , & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) + eflx_bot => col_ef%eflx_bot & ! Input: [real(r8) (:) ] heat flux from beneath column (W/m**2) [+ = upward] + ) + + ! Determine heat diffusion through the layer interface and factor used in computing + ! tridiagonal matrix and set up vector r and vectors a, b, c that define tridiagonal + ! matrix and solve system + + !$acc parallel loop independent gang default(present) + do j = -nlevsno+1,nlevgrnd + !$acc loop vector independent + do fc = 1,num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof) .and. j <= nlevurb) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + fact(c,j) = dtime/cv(fc,j) + fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) + else if (j <= nlevurb-1) then + fact(c,j) = dtime/cv(fc,j) + fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) + dzm = (z(c,j)-z(c,j-1)) + else if (j == nlevurb) then + fact(c,j) = dtime/cv(fc,j) + ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across + ! the bottom "soil" layer and the equations are derived assuming a prescribed internal + ! building temperature. (See Oleson urban notes of 6/18/03). + fn(c,j) = tk(c,j) * (t_building(l) - cnfac*t_soisno(c,j))/(zi(c,j) - z(c,j)) + end if + end if + else if (col_pp%itype(c) /= icol_sunwall .and. col_pp%itype(c) /= icol_shadewall & + .and. col_pp%itype(c) /= icol_roof) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + fact(c,j) = dtime/cv(fc,j) * dz(c,j) / (0.5_r8*(z(c,j)-zi(c,j-1)+capr*(z(c,j+1)-zi(c,j-1)))) + fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) + else if (j <= nlevgrnd-1) then + fact(c,j) = dtime/cv(fc,j) + fn(c,j) = tk(c,j)*(t_soisno(c,j+1)-t_soisno(c,j))/(z(c,j+1)-z(c,j)) + dzm = (z(c,j)-z(c,j-1)) + else if (j == nlevgrnd) then + fact(c,j) = dtime/cv(fc,j) + fn(c,j) = eflx_bot(c) + end if + end if + end if + end do + end do + +end associate + +end subroutine ComputeHeatDiffFluxAndFactor !----------------------------------------------------------------------- subroutine SetRHSVec(bounds, num_filter, filter, dtime, & @@ -2067,7 +2152,6 @@ subroutine SetRHSVec(bounds, num_filter, filter, dtime, & ! !===========| ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac, cpliq use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -2090,17 +2174,14 @@ subroutine SetRHSVec(bounds, num_filter, filter, dtime, & real(r8) , intent(in) :: fn( bounds%begc: , -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] real(r8) , intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] real(r8) , intent(in) :: dz_h2osfc( bounds%begc: ) ! Thickness of standing water [m] - real(r8) , intent(out) :: rvector( bounds%begc: , -nlevsno: ) ! RHS vector used in numerical solution of temperature - logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false + real(r8) , intent(inout) :: rvector( bounds%begc: , -nlevsno: ) ! RHS vector used in numerical solution of temperature + logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false ! ! !LOCAL VARIABLES: - integer :: j,c ! indices - integer :: fc ! lake filtered column indices - real(r8) :: rt (bounds%begc:bounds%endc,-nlevsno+1:nlevgrnd) ! "r" vector for tridiagonal solution - real(r8) :: fn_h2osfc(bounds%begc:bounds%endc) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8) :: rt_snow(bounds%begc:bounds%endc,-nlevsno:-1) ! RHS vector corresponding to snow layers - real(r8) :: rt_ssw(bounds%begc:bounds%endc,1) ! RHS vector corresponding to standing surface water - real(r8) :: rt_soil(bounds%begc:bounds%endc,1:nlevgrnd) ! RHS vector corresponding to soil layer + integer :: j,c ! indices + integer :: fc ! lake filtered column indices + real(r8) :: fn_h2osfc!(1:num_filter) ! heat diffusion through standing-water/soil interface [W/m2] + real(r8) :: dzm ! used in computing tridiagonal matrix !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -2114,8 +2195,6 @@ subroutine SetRHSVec(bounds, num_filter, filter, dtime, & endc => bounds%endc & ! Input: [integer ] ending column index ) - ! Initialize - rvector(begc:endc, :) = spval call SetRHSVec_Snow(bounds, num_filter, filter, & hs_top_snow( begc:endc ), & @@ -2127,44 +2206,52 @@ subroutine SetRHSVec(bounds, num_filter, filter, dtime, & t_soisno ( begc:endc, -nlevsno+1: ), & t_h2osfc ( begc:endc ), & urban_column, & - rt_snow( begc:endc, -nlevsno:)) - - ! Set entries in RHS vector for surface water layer - call SetRHSVec_StandingSurfaceWater(bounds, num_filter, filter, & - dtime, & - hs_h2osfc( begc:endc ), & - dhsdT( begc:endc ), & - tk_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - dz_h2osfc( begc:endc ), & - fn_h2osfc( begc:endc ), & - t_soisno ( begc:endc, -nlevsno+1: ), & - t_h2osfc ( begc:endc), & - rt_ssw( begc:endc, 1:1)) - - ! Set entries in RHS vector for soil layers - call SetRHSVec_Soil(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - frac_h2osfc ( begc:endc), & - frac_sno_eff( begc:endc), & - t_soisno ( begc:endc, -nlevsno+1: ), & - urban_column, & - rt_soil( begc:endc, 1: )) - - ! Combine the RHS vector + rvector( begc:endc, -nlevsno:)) + + ! ! Set entries in RHS vector for surface water layer + ! call SetRHSVec_StandingSurfaceWater(bounds, num_filter, filter, & + ! dtime, & + ! hs_h2osfc( begc:endc ), & + ! dhsdT( begc:endc ), & + ! tk_h2osfc( begc:endc ), & + ! c_h2osfc( begc:endc ), & + ! dz_h2osfc( begc:endc ), & + ! t_soisno ( begc:endc, -nlevsno+1: ), & + ! t_h2osfc ( begc:endc), & + ! rvector( begc:endc, 0)) + + + ! Set entries in RHS vector for soil layers + call SetRHSVec_Soil(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_soil( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + c_h2osfc( begc:endc ), & + frac_h2osfc ( begc:endc), & + frac_sno_eff( begc:endc), & + t_soisno ( begc:endc, -nlevsno+1: ), & + urban_column, & + rvector( begc:endc, 1:nlevgrnd )) + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) - rvector(c, -nlevsno:-1) = rt_snow(c, -nlevsno:-1) - rvector(c, 0 ) = rt_ssw(c, 1 ) - rvector(c, 1:nlevgrnd) = rt_soil(c, 1:nlevgrnd ) + + ! surface water layer has two coefficients + dzm=(0.5*dz_h2osfc(c)+col_pp%z(c,1)) + + fn_h2osfc = tk_h2osfc(c)*(t_soisno(c,1)-t_h2osfc(c))/dzm + rvector(c,0)= t_h2osfc(c) + (dtime/c_h2osfc(c)) & + *( hs_h2osfc(c) - dhsdT(c)*t_h2osfc(c) + cnfac*fn_h2osfc )!rhs for h2osfc + if ( frac_h2osfc(c) /= 0.0_r8 )then + rvector(c,1) = rvector(c,1) & + -frac_h2osfc(c)*fact(c,1)*((hs_soil(c) - dhsdT(c)*t_soisno(c,1)) & + +cnfac*fn_h2osfc ) + end if end do end associate @@ -2173,70 +2260,66 @@ end subroutine SetRHSVec !----------------------------------------------------------------------- subroutine SetRHSVec_Snow(bounds, num_filter, filter, & - hs_top_snow, hs_top, dhsdT, sabg_lyr_col, & - fact, fn, t_soisno, t_h2osfc, urban_column, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to snow layers. - ! - ! !USES: - !$acc routine seq - use elm_varpar , only : nlevsno, nlevgrnd - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_top( bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT( bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col( bounds%begc: , -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: , -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(in) :: t_h2osfc(bounds%begc:) ! surface water temperature (Kelvin) - logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: rt(bounds%begc: , -nlevsno: ) ! rhs vector entries - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index - ) - - ! Initialize - rt(begc:endc, : ) = spval - - if (urban_column) then - call SetRHSVec_SnowUrban(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - t_soisno ( begc:endc, -nlevsno+1: ), & - t_h2osfc ( begc:endc ), & - rt( begc:endc, -nlevsno:)) - - else - call SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - t_soisno ( begc:endc, -nlevsno+1: ), & - rt( begc:endc, -nlevsno:)) - endif - - end associate - - end subroutine SetRHSVec_Snow + hs_top_snow, hs_top, dhsdT, sabg_lyr_col, & + fact, fn, t_soisno, t_h2osfc, urban_column, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to snow layers. +! +! !USES: +use elm_varpar , only : nlevsno, nlevgrnd +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow( bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_top( bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT( bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col( bounds%begc: , -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: , -nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +real(r8), intent(in) :: t_h2osfc(bounds%begc:) ! surface water temperature (Kelvin) +logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false +real(r8), intent(inout) :: rt(bounds%begc: , -nlevsno: ) ! rhs vector entries +!----------------------------------------------------------------------- + +! Enforce expected array sizes + +associate( & + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc & ! Input: [integer ] ending column index + ) + + if (urban_column) then + call SetRHSVec_SnowUrban(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + t_soisno ( begc:endc, -nlevsno+1: ), & + t_h2osfc ( begc:endc ), & + rt( begc:endc, -nlevsno:)) + + else + call SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + t_soisno ( begc:endc, -nlevsno+1: ), & + rt( begc:endc, -nlevsno:)) + endif + +end associate + +end subroutine SetRHSVec_Snow !----------------------------------------------------------------------- subroutine SetRHSVec_SnowUrban(bounds, num_filter, filter, & @@ -2247,7 +2330,6 @@ subroutine SetRHSVec_SnowUrban(bounds, num_filter, filter, & ! Sets up RHS vector corresponding to snow layers for urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -2314,7 +2396,6 @@ subroutine SetRHSVec_SnowUrbanNonRoad(bounds, num_filter, filter, & ! Sets up RHS vector corresponding to snow layers for urban sunwall/shadewall/roof columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -2338,8 +2419,6 @@ subroutine SetRHSVec_SnowUrbanNonRoad(bounds, num_filter, filter, & integer :: fc ! lake filtered column indices real(r8) :: dzm ! used in computing tridiagonal matrix real(r8) :: dzp ! used in computing tridiagonal matrix - real(r8) :: rt_snow_urban(bounds%begc:bounds%endc,-nlevsno:-1) ! rhs vector entries for urban columns - real(r8) :: rt_snow_nonurban(bounds%begc:bounds%endc,-nlevsno:-1) ! rhs vector entries for non-urban columns !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -2351,7 +2430,9 @@ subroutine SetRHSVec_SnowUrbanNonRoad(bounds, num_filter, filter, & ! ! urban columns ------------------------------------------------------------------ ! + !$acc parallel loop independent gang default(present) do j = -nlevsno+1,0 + !$acc loop vector independent do fc = 1,num_filter c = filter(fc) l = col_pp%landunit(c) @@ -2389,7 +2470,6 @@ subroutine SetRHSVec_SnowUrbanRoad(bounds, num_filter, filter, & ! (impervious + pervious) columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_road_perv, icol_road_imperv use elm_varpar , only : nlevsno, nlevgrnd @@ -2414,8 +2494,6 @@ subroutine SetRHSVec_SnowUrbanRoad(bounds, num_filter, filter, & integer :: fc ! lake filtered column indices real(r8) :: dzm ! used in computing tridiagonal matrix real(r8) :: dzp ! used in computing tridiagonal matrix - real(r8) :: rt_snow_urban(bounds%begc:bounds%endc,-nlevsno:-1) ! - real(r8) :: rt_snow_nonurban(bounds%begc:bounds%endc,-nlevsno:-1) ! !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -2427,7 +2505,9 @@ subroutine SetRHSVec_SnowUrbanRoad(bounds, num_filter, filter, & ! ! urban road columns ------------------------------------------------------------- ! + !$acc parallel loop independent gang default(present) do j = -nlevsno+1,0 + !$acc loop vector independent do fc = 1,num_filter c = filter(fc) l = col_pp%landunit(c) @@ -2466,7 +2546,6 @@ subroutine SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & ! Sets up RHS vector corresponding to snow layers for non-urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -2501,6 +2580,7 @@ subroutine SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & ! ! non-urban columns -------------------------------------------------------------- ! + !$acc parallel loop independent gang vector default(present) collapse(2) do j = -nlevsno+1,0 do fc = 1,num_filter c = filter(fc) @@ -2515,7 +2595,7 @@ subroutine SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & else dzm = (z(c,j)-z(c,j-1)) dzp = (z(c,j+1)-z(c,j)) - + rt(c,j-1) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) rt(c,j-1) = rt(c,j-1) + fact(c,j)*sabg_lyr_col(c,j) @@ -2529,521 +2609,398 @@ subroutine SetRHSVec_SnowNonUrban(bounds, num_filter, filter, & end subroutine SetRHSVec_SnowNonUrban - !----------------------------------------------------------------------- - subroutine SetRHSVec_StandingSurfaceWater(bounds, num_filter, filter, dtime, & - hs_h2osfc, dhsdT, tk_h2osfc, c_h2osfc, dz_h2osfc, fn_h2osfc, & - t_soisno, t_h2osfc, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to standing surface water - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: dtime ! land model time step (sec) - real(r8), intent(in) :: hs_h2osfc(bounds%begc: ) ! - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: tk_h2osfc(bounds%begc: ) ! - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: dz_h2osfc(bounds%begc: ) ! Thickness of standing water [m] - real(r8), intent(out) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(in) :: t_h2osfc(bounds%begc:) ! surface water temperature temperature (Kelvin) - real(r8), intent(out) :: rt(bounds%begc:bounds%endc, 1:1 ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c ! indices - integer :: fc ! lake filtered column indices - real(r8) :: dzm ! used in computing tridiagonal matrix - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - ! Initialize - rt(bounds%begc:bounds%endc, : ) = spval - - ! - ! surface water ------------------------------------------------------------------ - ! - do fc = 1,num_filter - c = filter(fc) - - ! surface water layer has two coefficients - dzm=(0.5*dz_h2osfc(c)+col_pp%z(c,1)) - - fn_h2osfc(c)=tk_h2osfc(c)*(t_soisno(c,1)-t_h2osfc(c))/dzm - rt(c,1)= t_h2osfc(c) + (dtime/c_h2osfc(c)) & - *( hs_h2osfc(c) - dhsdT(c)*t_h2osfc(c) + cnfac*fn_h2osfc(c) )!rhs for h2osfc - - enddo - - end subroutine SetRHSVec_StandingSurfaceWater !----------------------------------------------------------------------- subroutine SetRHSVec_Soil(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - frac_h2osfc, frac_sno_eff, t_soisno, urban_column, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: frac_h2osfc(bounds%begc: ) ! fractional area with surface water greater than zero - real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: rt(bounds%begc: ,1: ) ! rhs vector entries - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate(& - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index - ) - - ! Initialize - rt(begc:endc, : ) = spval - - if (urban_column) then - call SetRHSVec_SoilUrban(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - frac_sno_eff( begc:endc ), & - t_soisno( begc:endc, -nlevsno+1: ), & - rt( begc:endc, 1: )) - else - call SetRHSVec_SoilNonUrban(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - frac_sno_eff(begc:endc), & - t_soisno( begc:endc, -nlevsno+1: ), & - rt( begc:endc, 1: )) - endif - - call SetRHSVec_Soil_StandingSurfaceWater(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - frac_h2osfc(begc:endc), & - t_soisno( begc:endc, -nlevsno+1: ), & - rt( begc:endc, 1: )) - - end associate - - end subroutine SetRHSVec_Soil - - !----------------------------------------------------------------------- - subroutine SetRHSVec_SoilUrban(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - frac_sno_eff, t_soisno, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers for urban columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index - ) - - call SetRHSVec_SoilUrbanNonRoad(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - t_soisno( begc:endc, -nlevsno+1: ), & - rt( begc:endc, 1: )) - - call SetRHSVec_SoilUrbanRoad(bounds, num_filter, filter, & - hs_top_snow( begc:endc ), & - hs_soil( begc:endc ), & - hs_top( begc:endc ), & - dhsdT( begc:endc ), & - sabg_lyr_col (begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - fn( begc:endc, -nlevsno+1: ), & - fn_h2osfc( begc:endc ), & - c_h2osfc( begc:endc ), & - frac_sno_eff( begc:endc ), & - t_soisno( begc:endc, -nlevsno+1: ), & - rt( begc:endc, 1: )) - - end associate - - end subroutine SetRHSVec_SoilUrban - - !----------------------------------------------------------------------- - subroutine SetRHSVec_SoilUrbanNonRoad(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - t_soisno, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers for urban sunwall/shadewall/roof columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - z => col_pp%z & ! Input: [real(r8) (:,:) ] layer thickness (m) - ) + hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, c_h2osfc, & + frac_h2osfc, frac_sno_eff, t_soisno, urban_column, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to soil layers +! +! !USES: +use elm_varcon , only : cnfac +use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] +real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] +real(r8), intent(in) :: frac_h2osfc(bounds%begc: ) ! fractional area with surface water greater than zero +real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false +real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries +!----------------------------------------------------------------------- + +! Enforce expected array sizes + +associate(& + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc & ! Input: [integer ] ending column index + ) + + if (urban_column) then + call SetRHSVec_SoilUrban(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_soil( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + c_h2osfc( begc:endc ), & + frac_sno_eff( begc:endc ), & + t_soisno( begc:endc, -nlevsno+1: ), & + rt( begc:endc, 1: )) + else + call SetRHSVec_SoilNonUrban(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_soil( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + c_h2osfc( begc:endc ), & + frac_sno_eff(begc:endc), & + t_soisno( begc:endc, -nlevsno+1: ), & + rt( begc:endc, 1: )) + endif + + ! call SetRHSVec_Soil_StandingSurfaceWater(bounds, num_filter, filter, & + ! hs_top_snow( begc:endc ), & + ! hs_soil( begc:endc ), & + ! hs_top( begc:endc ), & + ! dhsdT( begc:endc ), & + ! sabg_lyr_col (begc:endc, -nlevsno+1: ), & + ! fact( begc:endc, -nlevsno+1: ), & + ! fn( begc:endc, -nlevsno+1: ), & + ! fn_h2osfc( 1:num_filter ), & + ! c_h2osfc( begc:endc ), & + ! frac_h2osfc(begc:endc), & + ! t_soisno( begc:endc, -nlevsno+1: ), & + ! rt( begc:endc, 1: )) + +end associate + +end subroutine SetRHSVec_Soil + +!----------------------------------------------------------------------- +subroutine SetRHSVec_SoilUrban(bounds, num_filter, filter, & + hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, c_h2osfc, & + frac_sno_eff, t_soisno, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to soil layers for urban columns +! +! !USES: +use elm_varcon , only : cnfac +use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] +real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] +real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries +! +! !LOCAL VARIABLES: +integer :: j,c,l ! indices +integer :: fc ! lake filtered column indices +!----------------------------------------------------------------------- + +! Enforce expected array sizes + +associate( & + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc & ! Input: [integer ] ending column index + ) + + call SetRHSVec_SoilUrbanNonRoad(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_soil( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + c_h2osfc( begc:endc ), & + t_soisno( begc:endc, -nlevsno+1: ), & + rt( begc:endc, 1: )) + + call SetRHSVec_SoilUrbanRoad(bounds, num_filter, filter, & + hs_top_snow( begc:endc ), & + hs_soil( begc:endc ), & + hs_top( begc:endc ), & + dhsdT( begc:endc ), & + sabg_lyr_col (begc:endc, -nlevsno+1: ), & + fact( begc:endc, -nlevsno+1: ), & + fn( begc:endc, -nlevsno+1: ), & + c_h2osfc( begc:endc ), & + frac_sno_eff( begc:endc ), & + t_soisno( begc:endc, -nlevsno+1: ), & + rt( begc:endc, 1: )) + +end associate + +end subroutine SetRHSVec_SoilUrban + +!----------------------------------------------------------------------- +subroutine SetRHSVec_SoilUrbanNonRoad(bounds, num_filter, filter, & + hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, c_h2osfc, & + t_soisno, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to soil layers for urban sunwall/shadewall/roof columns +! +! !USES: +use elm_varcon , only : cnfac +use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] +real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries +! +! !LOCAL VARIABLES: +integer :: j,c,l ! indices +integer :: fc ! lake filtered column indices +!----------------------------------------------------------------------- +! Enforce expected array sizes + +associate( & + z => col_pp%z & ! Input: [real(r8) (:,:) ] layer thickness (m) + ) - ! - ! urban columns ------------------------------------------------------------------ - ! - do j = 1,nlevurb - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then - if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & - .or. col_pp%itype(c) == icol_roof)) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - ! changed hs to hs_top - rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top(c) - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) - else if (j <= nlevurb-1) then - ! if this is a snow layer or the top soil layer, - ! add absorbed solar flux to factor 'rt' - if (j == 1) then - rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) - rt(c,j) = rt(c,j) + (fact(c,j)*sabg_lyr_col(c,j)) - else - rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) - endif - - else if (j == nlevurb) then - ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across - ! the bottom "soil" layer and the equations are derived assuming a prescribed internal - ! building temperature. (See Oleson urban notes of 6/18/03). - rt(c,j) = t_soisno(c,j) + fact(c,j)*( fn(c,j) - cnfac*fn(c,j-1) ) - end if - end if - end if - end if - enddo - end do - - end associate - - end subroutine SetRHSVec_SoilUrbanNonRoad - - !----------------------------------------------------------------------- - subroutine SetRHSVec_SoilUrbanRoad(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - frac_sno_eff, t_soisno, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers for urban road - ! (impervious + pervious) columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_road_perv, icol_road_imperv - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - z => col_pp%z & ! Input: [real(r8) (:,:) ] layer thickness (m) - ) - - ! - ! urban road columns ------------------------------------------------------------- - ! - do j = 1,nlevgrnd - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then - if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then - if (j == col_pp%snl(c)+1) then - rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top_snow(c) & - - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) - else if (j == 1) then - ! this is the snow/soil interface layer - rt(c,j) = t_soisno(c,j) + fact(c,j) & - *((1._r8-frac_sno_eff(c))*(hs_soil(c) - dhsdT(c)*t_soisno(c,j)) & - + cnfac*(fn(c,j) - frac_sno_eff(c) * fn(c,j-1))) - - rt(c,j) = rt(c,j) + frac_sno_eff(c)*fact(c,j)*sabg_lyr_col(c,j) - - else if (j <= nlevgrnd-1) then - rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) - - else if (j == nlevgrnd) then - rt(c,j) = t_soisno(c,j) - cnfac*fact(c,j)*fn(c,j-1) + fact(c,j)*fn(c,j) - end if - end if - end if - enddo - end do - - end associate - - end subroutine SetRHSVec_SoilUrbanRoad - - !----------------------------------------------------------------------- - subroutine SetRHSVec_SoilNonUrban(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - frac_sno_eff, t_soisno, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers. - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fractional area with surface water greater than zero - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) - ) - - ! - ! non-urban columns -------------------------------------------------------------- - ! - do j = 1,nlevgrnd - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (.not. lun_pp%urbpoi(l)) then - if (j == col_pp%snl(c)+1) then - rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top_snow(c) & - - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) - else if (j == 1) then - ! this is the snow/soil interface layer - rt(c,j) = t_soisno(c,j) + fact(c,j) & - *((1._r8-frac_sno_eff(c))*(hs_soil(c) - dhsdT(c)*t_soisno(c,j)) & - + cnfac*(fn(c,j) - frac_sno_eff(c) * fn(c,j-1))) - - rt(c,j) = rt(c,j) + frac_sno_eff(c)*fact(c,j)*sabg_lyr_col(c,j) - - else if (j <= nlevgrnd-1) then - rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) - - else if (j == nlevgrnd) then - rt(c,j) = t_soisno(c,j) - cnfac*fact(c,j)*fn(c,j-1) + fact(c,j)*fn(c,j) - end if - end if - enddo - end do - - end associate - - end subroutine SetRHSVec_SoilNonUrban - - !----------------------------------------------------------------------- - subroutine SetRHSVec_Soil_StandingSurfaceWater(bounds, num_filter, filter, & - hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, fn_h2osfc, c_h2osfc, & - frac_h2osfc, t_soisno, rt) - ! - ! !DESCRIPTION: - ! Sets up RHS vector corresponding to soil layers. - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] - real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] - real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] - real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] - real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] - real(r8), intent(in) :: fn_h2osfc (bounds%begc: ) ! heat diffusion through standing-water/soil interface [W/m2] - real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] - real(r8), intent(in) :: frac_h2osfc(bounds%begc: ) ! fractional area with surface water greater than zero - real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) - real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes + ! + ! urban columns ------------------------------------------------------------------ + ! + !$acc parallel loop independent gang default(present) + do j = 1,nlevurb + !$acc loop vector independent + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (lun_pp%urbpoi(l)) then + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof)) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + ! changed hs to hs_top + rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top(c) - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) + else if (j <= nlevurb-1) then + ! if this is a snow layer or the top soil layer, + ! add absorbed solar flux to factor 'rt' + if (j == 1) then + rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) + rt(c,j) = rt(c,j) + (fact(c,j)*sabg_lyr_col(c,j)) + else + rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) + endif + + else if (j == nlevurb) then + ! For urban sunwall, shadewall, and roof columns, there is a non-zero heat flux across + ! the bottom "soil" layer and the equations are derived assuming a prescribed internal + ! building temperature. (See Oleson urban notes of 6/18/03). + rt(c,j) = t_soisno(c,j) + fact(c,j)*( fn(c,j) - cnfac*fn(c,j-1) ) + end if + end if + end if + end if + enddo + end do + +end associate + +end subroutine SetRHSVec_SoilUrbanNonRoad + +!----------------------------------------------------------------------- +subroutine SetRHSVec_SoilUrbanRoad(bounds, num_filter, filter, & + hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, c_h2osfc, & + frac_sno_eff, t_soisno, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to soil layers for urban road +! (impervious + pervious) columns +! +! !USES: +use elm_varcon , only : cnfac +use column_varcon , only : icol_road_perv, icol_road_imperv +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] +real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] +real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries +! +! !LOCAL VARIABLES: +integer :: j,c,l ! indices +integer :: fc ! lake filtered column indices +!----------------------------------------------------------------------- +! Enforce expected array sizes + +associate( & + z => col_pp%z & ! Input: [real(r8) (:,:) ] layer thickness (m) + ) - ! - ! surface water ----------------------------------------------------------------- - ! - do fc = 1,num_filter - c = filter(fc) - if ( frac_h2osfc(c) /= 0.0_r8 )then - rt(c,1)=rt(c,1) & - -frac_h2osfc(c)*fact(c,1)*((hs_soil(c) - dhsdT(c)*t_soisno(c,1)) & - +cnfac*fn_h2osfc(c)) - end if - end do + ! + ! urban road columns ------------------------------------------------------------- + ! + !$acc parallel loop independent gang default(present) + do j = 1,nlevgrnd + !$acc loop vector independent + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (lun_pp%urbpoi(l)) then + if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then + if (j == col_pp%snl(c)+1) then + rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top_snow(c) & + - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) + else if (j == 1) then + ! this is the snow/soil interface layer + rt(c,j) = t_soisno(c,j) + fact(c,j) & + *((1._r8-frac_sno_eff(c))*(hs_soil(c) - dhsdT(c)*t_soisno(c,j)) & + + cnfac*(fn(c,j) - frac_sno_eff(c) * fn(c,j-1))) + + rt(c,j) = rt(c,j) + frac_sno_eff(c)*fact(c,j)*sabg_lyr_col(c,j) + + else if (j <= nlevgrnd-1) then + rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) + + else if (j == nlevgrnd) then + rt(c,j) = t_soisno(c,j) - cnfac*fact(c,j)*fn(c,j-1) + fact(c,j)*fn(c,j) + end if + end if + end if + enddo + end do + +end associate + +end subroutine SetRHSVec_SoilUrbanRoad + +!----------------------------------------------------------------------- +subroutine SetRHSVec_SoilNonUrban(bounds, num_filter, filter, & + hs_top_snow, hs_soil, hs_top, dhsdT, sabg_lyr_col, fact, fn, c_h2osfc, & + frac_sno_eff, t_soisno, rt) +! +! !DESCRIPTION: +! Sets up RHS vector corresponding to soil layers. +! +! !USES: +use elm_varcon , only : cnfac +use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall +use elm_varpar , only : nlevsno, nlevgrnd, nlevurb +! +! !ARGUMENTS: +implicit none +type(bounds_type), intent(in) :: bounds ! bounds +integer , intent(in) :: num_filter ! number of column the in filter +integer , intent(in) :: filter(:) ! column filter +real(r8), intent(in) :: hs_top_snow(bounds%begc: ) ! heat flux on top snow layer [W/m2] +real(r8), intent(in) :: hs_soil(bounds%begc: ) ! heat flux on soil [W/m2] +real(r8), intent(in) :: hs_top(bounds%begc: ) ! net energy flux into surface layer (col) [W/m2] +real(r8), intent(in) :: dhsdT(bounds%begc: ) ! temperature derivative of "hs" [col] +real(r8), intent(in) :: sabg_lyr_col(bounds%begc:, -nlevsno+1: ) ! absorbed solar radiation (col,lyr) [W/m2] +real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] +real(r8), intent(in) :: fn (bounds%begc: ,-nlevsno+1: ) ! heat diffusion through the layer interface [W/m2] +real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] +real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fractional area with surface water greater than zero +real(r8), intent(in) :: t_soisno(bounds%begc:, -nlevsno+1:) ! soil temperature (Kelvin) +real(r8), intent(inout) :: rt(bounds%begc: ,1: ) ! rhs vector entries +! +! !LOCAL VARIABLES: +integer :: j,c,l ! indices +integer :: fc ! lake filtered column indices +!----------------------------------------------------------------------- + +! Enforce expected array sizes + +associate( & + z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) + ) - end subroutine SetRHSVec_Soil_StandingSurfaceWater + ! + ! non-urban columns -------------------------------------------------------------- + ! + !$acc parallel loop independent gang default(present) + do j = 1,nlevgrnd + !$acc loop vector independent + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (.not. lun_pp%urbpoi(l)) then + if (j == col_pp%snl(c)+1) then + rt(c,j) = t_soisno(c,j) + fact(c,j)*( hs_top_snow(c) & + - dhsdT(c)*t_soisno(c,j) + cnfac*fn(c,j) ) + else if (j == 1) then + ! this is the snow/soil interface layer + rt(c,j) = t_soisno(c,j) + fact(c,j) & + *((1._r8-frac_sno_eff(c))*(hs_soil(c) - dhsdT(c)*t_soisno(c,j)) & + + cnfac*(fn(c,j) - frac_sno_eff(c) * fn(c,j-1))) + + rt(c,j) = rt(c,j) + frac_sno_eff(c)*fact(c,j)*sabg_lyr_col(c,j) + + else if (j <= nlevgrnd-1) then + rt(c,j) = t_soisno(c,j) + cnfac*fact(c,j)*( fn(c,j) - fn(c,j-1) ) + + else if (j == nlevgrnd) then + rt(c,j) = t_soisno(c,j) - cnfac*fact(c,j)*fn(c,j-1) + fact(c,j)*fn(c,j) + end if + end if + enddo + end do + +end associate + +end subroutine SetRHSVec_SoilNonUrban !----------------------------------------------------------------------- subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & @@ -3066,7 +3023,6 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & ! ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3084,7 +3040,7 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] real(r8), intent(in) :: dz_h2osfc(bounds%begc: ) ! Thickness of standing water [m] - real(r8), intent(out) :: bmatrix(bounds%begc: , 1:,-nlevsno: ) ! matrix for numerical solution of temperature + real(r8), intent(inout) :: bmatrix(bounds%begc: , 1:,-nlevsno: ) ! matrix for numerical solution of temperature logical, intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false ! ! !LOCAL VARIABLES: @@ -3122,13 +3078,13 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & fact( begc:endc, -nlevsno+1: ), & frac_sno_eff(begc:endc), & urban_column, & - bmatrix_snow( begc:endc, 1:, -nlevsno: )) + bmatrix( begc:endc, 1:, -nlevsno: )) call SetMatrix_Snow_Soil(bounds, num_filter, filter, nband, & tk( begc:endc, -nlevsno+1: ), & fact( begc:endc, -nlevsno+1: ), & urban_column, & - bmatrix_snow_soil( begc:endc, 1:, -1: )) + bmatrix( begc:endc, 1:, -1: )) call SetMatrix_Soil(bounds, num_filter, filter, nband, & dhsdT( begc:endc ), & @@ -3139,14 +3095,14 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & frac_h2osfc(begc:endc), & frac_sno_eff(begc:endc), & urban_column, & - bmatrix_soil( begc:endc, 1:, 1: )) + bmatrix( begc:endc, 1:, 1: )) call SetMatrix_Soil_Snow(bounds, num_filter, filter, nband, & tk( begc:endc, -nlevsno+1: ), & fact( begc:endc, -nlevsno+1: ), & frac_sno_eff(begc:endc), & urban_column, & - bmatrix_soil_snow( begc:endc, 1:, 1: )) + bmatrix( begc:endc, 1:, 1: )) call SetMatrix_StandingSurfaceWater(bounds, num_filter, filter, dtime, nband, & dhsdT( begc:endc ), & @@ -3155,7 +3111,7 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & fact( begc:endc, -nlevsno+1: ), & c_h2osfc( begc:endc ), & dz_h2osfc( begc:endc ), & - bmatrix_ssw( begc:endc, 1:, 0: )) + bmatrix( begc:endc, 1:, 0: )) call SetMatrix_StandingSurfaceWater_Soil(bounds, num_filter, filter, dtime, nband, & tk( begc:endc, -nlevsno+1: ), & @@ -3163,140 +3119,19 @@ subroutine SetMatrix(bounds, num_filter, filter, dtime, nband, & fact( begc:endc, -nlevsno+1: ), & c_h2osfc( begc:endc ), & dz_h2osfc( begc:endc ), & - bmatrix_ssw_soil( begc:endc, 1:, 0: )) + bmatrix( begc:endc, 1:, 0: )) call SetMatrix_Soil_StandingSurfaceWater(bounds, num_filter, filter, nband, & tk_h2osfc( begc:endc ), & fact( begc:endc, -nlevsno+1: ), & dz_h2osfc( begc:endc ), & frac_h2osfc(begc:endc), & - bmatrix_soil_ssw( begc:endc, 1:, 1: )) - - call AssembleMatrixFromSubmatrices(bounds, num_filter, filter, nband, & - bmatrix_snow( begc:endc, 1:, -nlevsno: ), & - bmatrix_ssw( begc:endc, 1:, 0: ), & - bmatrix_soil( begc:endc, 1:, 1: ), & - bmatrix_snow_soil( begc:endc, 1:, -1: ), & - bmatrix_ssw_soil( begc:endc, 1:, 0: ), & - bmatrix_soil_snow( begc:endc, 1:, 1: ), & - bmatrix_soil_ssw( begc:endc, 1:, 1: ), & - bmatrix( begc:endc, 1:, -nlevsno: )) - + bmatrix( begc:endc, 1:, 1: )) end associate end subroutine SetMatrix - !----------------------------------------------------------------------- - subroutine AssembleMatrixFromSubmatrices(bounds, num_filter, filter, nband, & - bmatrix_snow, bmatrix_ssw, bmatrix_soil, bmatrix_snow_soil, & - bmatrix_ssw_soil, bmatrix_soil_snow, bmatrix_soil_ssw, bmatrix) - - ! - ! !DESCRIPTION: - ! Assemble the full matrix from submatrices. - ! - ! Non-zero pattern of bmatrix: - ! - ! SNOW-LAYERS - ! | - ! | STANDING-SURFACE-WATER - ! | | - ! | | SOIL-LAYERS - ! | | | - ! v v v - ! - ! -5 -4 -3 -2 -1| 0| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 - ! ============================================================== - ! -5 | x x | | | - ! -4 | x x x | | | - ! -3 | x x x | | | - ! -2 | x x x| | | - ! -1 | x x| | x | - ! ============================================================== - ! 0 | | x| x | - ! ============================================================== - ! 1 | x| x| x x | - ! 2 | | | x x x | - ! 3 | | | x x x | - ! 4 | | | x x x | - ! 5 | | | x x x | - ! 6 | | | x x x | - ! 7 | | | x x x | - ! 8 | | | x x x | - ! 9 | | | x x x | - ! 10 | | | x x x | - ! 11 | | | x x x | - ! 12 | | | x x x | - ! 13 | | | x x x | - ! 14 | | | x x x| - ! 15 | | | x x| - ! ============================================================== - ! - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - integer , intent(in) :: nband ! number of bands of the tridigonal matrix - real(r8), intent(in) :: bmatrix_snow(bounds%begc:bounds%endc,nband,-nlevsno:-1 ) ! block-diagonal matrix for snow layers - real(r8), intent(in) :: bmatrix_ssw(bounds%begc:bounds%endc,nband, 0:0 ) ! block-diagonal matrix for standing surface water - real(r8), intent(in) :: bmatrix_soil(bounds%begc:bounds%endc,nband, 1:nlevgrnd) ! block-diagonal matrix for soil layers - real(r8), intent(in) :: bmatrix_snow_soil(bounds%begc:bounds%endc,nband,-1:-1) ! off-diagonal matrix for snow-soil interaction - real(r8), intent(in) :: bmatrix_ssw_soil(bounds%begc:bounds%endc,nband, 0:0 ) ! off-diagonal matrix for standing surface water-soil interaction - real(r8), intent(in) :: bmatrix_soil_snow(bounds%begc:bounds%endc,nband, 1:1 ) ! off-diagonal matrix for soil-snow interaction - real(r8), intent(in) :: bmatrix_soil_ssw(bounds%begc:bounds%endc,nband, 1:1 ) ! off-diagonal matrix for soil-standing surface water interaction - real(r8), intent(out) :: bmatrix(bounds%begc: , 1:,-nlevsno: ) ! full matrix used in numerical solution of temperature - ! - ! !LOCAL VARIABLES: - integer :: j,c ! indices - integer :: fc ! lake filtered column indices - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - ! Assemble the full matrix - - bmatrix(bounds%begc:bounds%endc, :, :) = 0.0_r8 - do fc = 1,num_filter - c = filter(fc) - - ! Snow - bmatrix(c,2:3,-nlevsno) = bmatrix_snow(c,2:3,-nlevsno) - bmatrix(c,2:4,-nlevsno+1:-2) = bmatrix_snow(c,2:4,-nlevsno+1:-2) - bmatrix(c,3:4,-1 ) = bmatrix_snow(c,3:4,-1 ) - - ! Snow-Soil - bmatrix(c,1,-1) = bmatrix_snow_soil(c,1,-1) - - ! StandingSurfaceWater - bmatrix(c,3,0) = bmatrix_ssw(c,3,0) - - ! StandingSurfaceWater-Soil - bmatrix(c,2,0) = bmatrix_ssw_soil(c,2,0) - - ! Soil - bmatrix(c,2:3,1 ) = bmatrix_soil(c,2:3,1 ) - bmatrix(c,2:4,2:nlevgrnd-1) = bmatrix_soil(c,2:4,2:nlevgrnd-1) - bmatrix(c,3:4,nlevgrnd ) = bmatrix_soil(c,3:4,nlevgrnd ) - - ! Soil-Snow - bmatrix(c,5,1) = bmatrix_soil_snow(c,5,1) - - ! Soil-StandingSurfaceWater - bmatrix(c,4,1) = bmatrix_soil_ssw(c,4,1) - - end do - - end subroutine AssembleMatrixFromSubmatrices - !----------------------------------------------------------------------- subroutine SetMatrix_Snow(bounds, num_filter, filter, nband, & dhsdT, tk, fact, frac_sno_eff, urban_column, bmatrix_snow) @@ -3305,7 +3140,6 @@ subroutine SetMatrix_Snow(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to internal snow layers ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3321,7 +3155,7 @@ subroutine SetMatrix_Snow(bounds, num_filter, filter, nband, & real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: bmatrix_snow(bounds%begc: , 1:, -nlevsno: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_snow(bounds%begc: , 1:, -nlevsno: ) ! matrix enteries !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -3332,8 +3166,6 @@ subroutine SetMatrix_Snow(bounds, num_filter, filter, nband, & ) ! Initialize - bmatrix_snow(begc:endc, :, :) = 0.0_r8 - if (urban_column) then call SetMatrix_SnowUrban(bounds, num_filter, filter, nband, & dhsdT( begc:endc ), & @@ -3362,7 +3194,6 @@ subroutine SetMatrix_SnowUrban(bounds, num_filter, filter, nband, & ! urban soil columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3377,31 +3208,77 @@ subroutine SetMatrix_SnowUrban(bounds, num_filter, filter, nband, & real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(inout) :: bmatrix_snow(bounds%begc: , 1:, -nlevsno: ) ! matrix enteries - !----------------------------------------------------------------------- - ! Enforce expected array sizes + integer :: j,l,c,fc ! indices + real(r8) :: dzm ! used in computing tridiagonal matrix + real(r8) :: dzp ! used in computing tridiagonal matrix + !----------------------------------------------------------------------- + ! Enforce expected array sizes + ! associate(& - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc , & ! Input: [integer ] ending column index + z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) ) - call SetMatrix_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & - dhsdT( begc:endc ), & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_snow( begc:endc, 1:, -nlevsno: )) + !$acc parallel loop independent gang default(present) + do j = -nlevsno+1,0 + !$acc loop vector independent + do fc=1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (lun_pp%urbpoi(l)) then + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof)) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_snow(c,4,j-1) = 0._r8 + bmatrix_snow(c,3,j-1) = 1._r8+(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp-fact(c,j)*dhsdT(c) + if ( j /= 0) then + bmatrix_snow(c,2,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp + end if + else if (j <= nlevurb-1) then + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_snow(c,4,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j-1)/dzm + bmatrix_snow(c,3,j-1) = 1._r8+ (1._r8-cnfac)*fact(c,j)*(tk(c,j)/dzp + tk(c,j-1)/dzm) + if (j /= 0) then + bmatrix_snow(c,2,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp + end if + end if + end if + end if + if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_snow(c,4,j-1) = 0._r8 + bmatrix_snow(c,3,j-1) = 1._r8+(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp-fact(c,j)*dhsdT(c) + if ( j /= 0) then + bmatrix_snow(c,2,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp + end if + else if (j <= nlevgrnd-1) then + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_snow(c,4,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j-1)/dzm + bmatrix_snow(c,3,j-1) = 1._r8+ (1._r8-cnfac)*fact(c,j)*(tk(c,j)/dzp + tk(c,j-1)/dzm) + if ( j /= 0) then + bmatrix_snow(c,2,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp + end if + end if + end if + end if - call SetMatrix_SnowUrbanRoad(bounds, num_filter, filter, nband, & - dhsdT( begc:endc ), & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_snow( begc:endc, 1:, -nlevsno: )) + end if + end do + end do end associate end subroutine SetMatrix_SnowUrban - + !----------------------------------------------------------------------- subroutine SetMatrix_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & dhsdT, tk, fact, bmatrix_snow) @@ -3412,7 +3289,6 @@ subroutine SetMatrix_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & ! urban sunwall/shadewall/roof columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3488,7 +3364,6 @@ subroutine SetMatrix_SnowUrbanRoad(bounds, num_filter, filter, nband, & ! urban road (impervious + pervious) columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_road_perv, icol_road_imperv use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3562,7 +3437,6 @@ subroutine SetMatrix_SnowNonUrban(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to internal snow layers for non-urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3594,6 +3468,7 @@ subroutine SetMatrix_SnowNonUrban(bounds, num_filter, filter, nband, & ! ! non-urban landunits ------------------------------------------------------------ ! + !$acc parallel loop independent gang vector collapse(2) default(present) do j = -nlevsno+1,0 do fc = 1,num_filter c = filter(fc) @@ -3634,7 +3509,6 @@ subroutine SetMatrix_Snow_Soil(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to snow-soil interaction ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3647,7 +3521,7 @@ subroutine SetMatrix_Snow_Soil(bounds, num_filter, filter, nband, & real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: bmatrix_snow_soil(bounds%begc: , 1:,-1: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_snow_soil(bounds%begc: , 1:,-1: ) ! matrix enteries !----------------------------------------------------------------------- ! Enforce expected array sizes @@ -3658,8 +3532,6 @@ subroutine SetMatrix_Snow_Soil(bounds, num_filter, filter, nband, & ) ! Initialize - bmatrix_snow_soil(begc:endc, :, :) = 0.0_r8 - if (urban_column) then call SetMatrix_Snow_SoilUrban(bounds, num_filter, filter, nband, & tk( begc:endc, -nlevsno+1: ), & @@ -3668,69 +3540,22 @@ subroutine SetMatrix_Snow_Soil(bounds, num_filter, filter, nband, & else call SetMatrix_Snow_SoilNonUrban(bounds, num_filter, filter, nband, & tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_snow_soil( begc:endc, 1:, -1: )) - endif - - end associate - - end subroutine SetMatrix_Snow_Soil - - !----------------------------------------------------------------------- - subroutine SetMatrix_Snow_SoilUrban(bounds, num_filter, filter, nband, & - tk, fact, bmatrix_snow_soil) - ! - ! !DESCRIPTION: - ! Setup the matrix entries corresponding to snow-soil interaction for urban columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - integer , intent(in) :: nband ! number of bands of the tridigonal matrix - real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(inout) :: bmatrix_snow_soil(bounds%begc: , 1:,-1: ) ! matrix enteries - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate(& - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index - ) - - call SetMatrix_Snow_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_snow_soil( begc:endc, 1:, -1: )) - - call SetMatrix_Snow_SoilUrbanRoad(bounds, num_filter, filter, nband, & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_snow_soil( begc:endc, 1:, -1: )) + fact( begc:endc, -nlevsno+1: ), & + bmatrix_snow_soil( begc:endc, 1:, -1: )) + endif end associate - end subroutine SetMatrix_Snow_SoilUrban + end subroutine SetMatrix_Snow_Soil !----------------------------------------------------------------------- - subroutine SetMatrix_Snow_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & + subroutine SetMatrix_Snow_SoilUrban(bounds, num_filter, filter, nband, & tk, fact, bmatrix_snow_soil) ! ! !DESCRIPTION: - ! Setup the matrix entries corresponding to snow-soil interaction for - ! urban sunwall/shadewall/roof columns + ! Setup the matrix entries corresponding to snow-soil interaction for urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3744,60 +3569,67 @@ subroutine SetMatrix_Snow_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(inout) :: bmatrix_snow_soil(bounds%begc: , 1:,-1: ) ! matrix enteries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - real(r8) :: dzm ! used in computing tridiagonal matrix - real(r8) :: dzp ! used in computing tridiagonal matrix !----------------------------------------------------------------------- - - ! Enforce expected array sizes + integer, parameter :: j = 0 + integer :: fc ,c ,l + real(r8) :: dzm ! used in computing tridiagonal matrix + real(r8) :: dzp ! used in computing tridiagonal matrix + associate(& + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc , & ! Input: [integer ] ending column index z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) ) - ! - ! urban non-road columns --------------------------------------------------------- - ! - do j = 0,0 - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then - if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & - .or. col_pp%itype(c) == icol_roof)) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - dzp = z(c,j+1)-z(c,j) - bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp - else if (j <= nlevurb-1) then - dzm = (z(c,j)-z(c,j-1)) - dzp = (z(c,j+1)-z(c,j)) - bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp - end if + + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (lun_pp%urbpoi(l)) then + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof)) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp + else if (j <= nlevurb-1) then + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp end if end if end if - enddo - end do + if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp + else if (j <= nlevgrnd-1) then + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp + end if + end if + end if + end if + enddo end associate - end subroutine SetMatrix_Snow_SoilUrbanNonRoad + end subroutine SetMatrix_Snow_SoilUrban !----------------------------------------------------------------------- - subroutine SetMatrix_Snow_SoilUrbanRoad(bounds, num_filter, filter, nband, & + subroutine SetMatrix_Snow_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & tk, fact, bmatrix_snow_soil) ! ! !DESCRIPTION: ! Setup the matrix entries corresponding to snow-soil interaction for - ! urban road (impervious + pervious) columns + ! urban sunwall/shadewall/roof columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac - use column_varcon , only : icol_road_perv, icol_road_imperv + use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb ! ! !ARGUMENTS: @@ -3822,21 +3654,21 @@ subroutine SetMatrix_Snow_SoilUrbanRoad(bounds, num_filter, filter, nband, & associate(& z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) ) - ! - ! urban road columns ------------------------------------------------------------- + ! urban non-road columns --------------------------------------------------------- ! do j = 0,0 do fc = 1,num_filter c = filter(fc) l = col_pp%landunit(c) if (lun_pp%urbpoi(l)) then - if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then + if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & + .or. col_pp%itype(c) == icol_roof)) then if (j >= col_pp%snl(c)+1) then if (j == col_pp%snl(c)+1) then dzp = z(c,j+1)-z(c,j) bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp - else if (j <= nlevgrnd-1) then + else if (j <= nlevurb-1) then dzm = (z(c,j)-z(c,j-1)) dzp = (z(c,j+1)-z(c,j)) bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp @@ -3849,7 +3681,8 @@ subroutine SetMatrix_Snow_SoilUrbanRoad(bounds, num_filter, filter, nband, & end associate - end subroutine SetMatrix_Snow_SoilUrbanRoad + end subroutine SetMatrix_Snow_SoilUrbanNonRoad + !----------------------------------------------------------------------- subroutine SetMatrix_Snow_SoilNonUrban(bounds, num_filter, filter, nband, & @@ -3860,7 +3693,6 @@ subroutine SetMatrix_Snow_SoilNonUrban(bounds, num_filter, filter, nband, & ! non-urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3876,7 +3708,8 @@ subroutine SetMatrix_Snow_SoilNonUrban(bounds, num_filter, filter, nband, & real(r8), intent(inout) :: bmatrix_snow_soil(bounds%begc: , 1:,-1: ) ! matrix enteries ! ! !LOCAL VARIABLES: - integer :: j,c,l ! indices + integer :: c,l ! indices + integer, parameter :: j = 0 integer :: fc ! lake filtered column indices real(r8) :: dzm ! used in computing tridiagonal matrix real(r8) :: dzp ! used in computing tridiagonal matrix @@ -3891,29 +3724,27 @@ subroutine SetMatrix_Snow_SoilNonUrban(bounds, num_filter, filter, nband, & ! ! non-urban columns -------------------------------------------------------------- ! - do j = 0,0 - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (.not. lun_pp%urbpoi(l)) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - dzp = z(c,j+1)-z(c,j) - bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp - else if (j <= nlevgrnd-1) then - dzm = (z(c,j)-z(c,j-1)) - dzp = (z(c,j+1)-z(c,j)) - bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp - end if + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (.not. lun_pp%urbpoi(l)) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_snow_soil(c,1,j-1) = -(1._r8-cnfac)*fact(c,j)*tk(c,j)/dzp + else if (j <= nlevgrnd-1) then + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_snow_soil(c,1,j-1) = - (1._r8-cnfac)*fact(c,j)* tk(c,j)/dzp end if end if - enddo - end do + end if + enddo end associate end subroutine SetMatrix_Snow_SoilNonUrban - !----------------------------------------------------------------------- subroutine SetMatrix_Soil(bounds, num_filter, filter, nband, & dhsdT, tk, tk_h2osfc, dz_h2osfc, fact, frac_h2osfc, frac_sno_eff, urban_column, & @@ -3923,7 +3754,6 @@ subroutine SetMatrix_Soil(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to internal soil layers. ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -3942,7 +3772,7 @@ subroutine SetMatrix_Soil(bounds, num_filter, filter, nband, & real(r8), intent(in) :: frac_h2osfc(bounds%begc: ) ! fractional area with surface water greater than zero real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: bmatrix_soil(bounds%begc: , 1:, 1: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_soil(bounds%begc: , 1:, 1: ) ! matrix enteries ! ! !LOCAL VARIABLES: integer :: j,c,l ! indices @@ -3959,7 +3789,7 @@ subroutine SetMatrix_Soil(bounds, num_filter, filter, nband, & ) ! Initialize - bmatrix_soil(begc:endc, :, :) = 0.0_r8 + ! bmatrix_soil(begc:endc, :, :) = 0.0_r8 if (urban_column) then call SetMatrix_SoilUrban(bounds, num_filter, filter, nband, & @@ -3985,6 +3815,7 @@ subroutine SetMatrix_Soil(bounds, num_filter, filter, nband, & ! the solution will be organized as (snow:h2osfc:soil) to minimize ! bandwidth; this requires a 5-element band instead of 3 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) @@ -4012,7 +3843,6 @@ subroutine SetMatrix_SoilUrban(bounds, num_filter, filter, nband, & ! urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4060,6 +3890,7 @@ subroutine SetMatrix_SoilUrban(bounds, num_filter, filter, nband, & end subroutine SetMatrix_SoilUrban + !----------------------------------------------------------------------- subroutine SetMatrix_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & dhsdT, tk, tk_h2osfc, dz_h2osfc, fact, bmatrix_soil) @@ -4069,7 +3900,6 @@ subroutine SetMatrix_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & ! urban sunwall/shadewall/roof columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4104,6 +3934,7 @@ subroutine SetMatrix_SoilUrbanNonRoad(bounds, num_filter, filter, nband, & ! ! urban non-road columns --------------------------------------------------------- ! + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1,nlevurb do fc = 1,num_filter c = filter(fc) @@ -4156,7 +3987,6 @@ subroutine SetMatrix_SoilUrbanRoad(bounds, num_filter, filter, nband, & ! urban road (impervious + pervious) columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_road_perv, icol_road_imperv use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4190,7 +4020,7 @@ subroutine SetMatrix_SoilUrbanRoad(bounds, num_filter, filter, nband, & ! ! urban road columns ------------------------------------------------------------- - ! + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1,nlevgrnd do fc = 1,num_filter c = filter(fc) @@ -4247,7 +4077,6 @@ subroutine SetMatrix_SoilNonUrban(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to internal soil layers. ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4281,7 +4110,7 @@ subroutine SetMatrix_SoilNonUrban(bounds, num_filter, filter, nband, & ! ! non-urban columns -------------------------------------------------------------- - ! + !$acc parallel loop independent gang vector collapse(2) default(present) do j = 1,nlevgrnd do fc = 1,num_filter c = filter(fc) @@ -4337,7 +4166,6 @@ subroutine SetMatrix_Soil_Snow(bounds, num_filter, filter, nband, & ! Setup the matrix entries corresponding to soil-snow interaction ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4352,7 +4180,7 @@ subroutine SetMatrix_Soil_Snow(bounds, num_filter, filter, nband, & real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) logical , intent(in) :: urban_column ! Is true if solving temperature for urban column, otherwise false - real(r8), intent(out) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries !------------------------------------------------------------------------------ ! Enforce expected array sizes @@ -4363,7 +4191,7 @@ subroutine SetMatrix_Soil_Snow(bounds, num_filter, filter, nband, & ) ! Initialize - bmatrix_soil_snow(begc:endc, :, :) = 0.0_r8 + ! bmatrix_soil_snow(begc:endc, :, :) = 0.0_r8 if (urban_column) then call SetMatrix_Soil_SnowUrban(bounds, num_filter, filter, nband, & @@ -4392,90 +4220,40 @@ subroutine SetMatrix_Soil_SnowUrban(bounds, num_filter, filter, nband, & ! urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb ! ! !ARGUMENTS: implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - integer , intent(in) :: nband ! number of bands of the tridigonal matrix - real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] + type(bounds_type), intent(in) :: bounds ! bounds + integer , intent(in) :: num_filter ! number of column the in filter + integer , intent(in) :: filter(:) ! column filter + integer , intent(in) :: nband ! number of bands of the tridigonal matrix + real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] + real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) real(r8), intent(inout) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate(& - begc => bounds%begc , & ! Input: [integer ] beginning column index - endc => bounds%endc & ! Input: [integer ] ending column index - ) - - call SetMatrix_Soil_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - bmatrix_soil_snow( begc:endc, 1:, 1: )) - - call SetMatrix_Soil_SnowUrbanRoad(bounds, num_filter, filter, nband, & - tk( begc:endc, -nlevsno+1: ), & - fact( begc:endc, -nlevsno+1: ), & - frac_sno_eff(begc:endc), & - bmatrix_soil_snow( begc:endc, 1:, 1: )) - - end associate - - end subroutine SetMatrix_Soil_SnowUrban - - !----------------------------------------------------------------------- - subroutine SetMatrix_Soil_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & - tk, fact, bmatrix_soil_snow) - ! - ! !DESCRIPTION: - ! Setup the matrix entries corresponding to soil-snow interaction for - ! urban sunwall/shadewall/roof columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - integer , intent(in) :: nband ! number of bands of the tridigonal matrix - real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(inout) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries - ! ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - real(r8) :: dzm ! used in computing tridiagonal matrix - real(r8) :: dzp ! used in computing tridiagonal matrix - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate( & - z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) + integer :: c,l ! indices + integer :: fc ! lake filtered column indices + real(r8) :: dzm ! used in computing tridiagonal matrix + real(r8) :: dzp ! used in computing tridiagonal matrix + integer, parameter :: j=1 + + associate(& + begc => bounds%begc , & ! Input: [integer ] beginning column index + endc => bounds%endc , & ! Input: [integer ] ending column index + z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) ) - ! - ! - do j = 1,1 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) l = col_pp%landunit(c) if (lun_pp%urbpoi(l)) then if ((col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall & - .or. col_pp%itype(c) == icol_roof)) then + .or. col_pp%itype(c) == icol_roof)) then if (j >= col_pp%snl(c)+1) then if (j == col_pp%snl(c)+1) then dzp = z(c,j+1)-z(c,j) @@ -4487,60 +4265,6 @@ subroutine SetMatrix_Soil_SnowUrbanNonRoad(bounds, num_filter, filter, nband, & end if end if end if - end if - enddo - end do - - end associate - - end subroutine SetMatrix_Soil_SnowUrbanNonRoad - - !----------------------------------------------------------------------- - subroutine SetMatrix_Soil_SnowUrbanRoad(bounds, num_filter, filter, nband, & - tk, fact, frac_sno_eff, bmatrix_soil_snow) - ! - ! !DESCRIPTION: - ! Setup the matrix entries corresponding to soil-snow interaction for - ! urban road (impervious + pervious) columns - ! - ! !USES: - !$acc routine seq - use elm_varcon , only : cnfac - use column_varcon , only : icol_road_imperv, icol_road_perv - use elm_varpar , only : nlevsno, nlevgrnd, nlevurb - ! - ! !ARGUMENTS: - implicit none - type(bounds_type), intent(in) :: bounds ! bounds - integer , intent(in) :: num_filter ! number of column the in filter - integer , intent(in) :: filter(:) ! column filter - integer , intent(in) :: nband ! number of bands of the tridigonal matrix - real(r8), intent(in) :: tk(bounds%begc: ,-nlevsno+1: ) ! thermal conductivity [W/(m K)] - real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] - real(r8), intent(in) :: frac_sno_eff(bounds%begc: ) ! fraction of ground covered by snow (0 to 1) - real(r8), intent(inout) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries - ! - ! !LOCAL VARIABLES: - integer :: j,c,l ! indices - integer :: fc ! lake filtered column indices - real(r8) :: dzm ! used in computing tridiagonal matrix - real(r8) :: dzp ! used in computing tridiagonal matrix - !----------------------------------------------------------------------- - - ! Enforce expected array sizes - - associate(& - z => col_pp%z & ! Input: [real(r8) (:,:)] layer thickness (m) - ) - - ! - ! urban road columns ------------------------------------------------------------- - ! - do j = 1,1 - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (lun_pp%urbpoi(l)) then if (col_pp%itype(c) == icol_road_imperv .or. col_pp%itype(c) == icol_road_perv) then if (j >= col_pp%snl(c)+1) then if (j == col_pp%snl(c)+1) then @@ -4550,20 +4274,19 @@ subroutine SetMatrix_Soil_SnowUrbanRoad(bounds, num_filter, filter, nband, & ! this is the snow/soil interface layer dzm = (z(c,j)-z(c,j-1)) dzp = (z(c,j+1)-z(c,j)) - + bmatrix_soil_snow(c,5,j) = - frac_sno_eff(c) * (1._r8-cnfac) * fact(c,j) & - * tk(c,j-1)/dzm + * tk(c,j-1)/dzm end if end if end if - end if - end do - end do + end if + enddo end associate - end subroutine SetMatrix_Soil_SnowUrbanRoad - + end subroutine SetMatrix_Soil_SnowUrban + !----------------------------------------------------------------------- subroutine SetMatrix_Soil_SnowNonUrban(bounds, num_filter, filter, nband, & tk, fact, frac_sno_eff, bmatrix_soil_snow) @@ -4573,7 +4296,6 @@ subroutine SetMatrix_Soil_SnowNonUrban(bounds, num_filter, filter, nband, & ! non urban columns ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd, nlevurb @@ -4590,8 +4312,9 @@ subroutine SetMatrix_Soil_SnowNonUrban(bounds, num_filter, filter, nband, & real(r8), intent(inout) :: bmatrix_soil_snow(bounds%begc: , 1: ,1: ) ! matrix enteries ! ! !LOCAL VARIABLES: - integer :: j,c,l ! indices + integer :: c,l ! indices integer :: fc ! lake filtered column indices + integer, parameter :: j = 1 real(r8) :: dzm ! used in computing tridiagonal matrix real(r8) :: dzp ! used in computing tridiagonal matrix !----------------------------------------------------------------------- @@ -4605,26 +4328,24 @@ subroutine SetMatrix_Soil_SnowNonUrban(bounds, num_filter, filter, nband, & ! ! non-urban columns -------------------------------------------------------------- ! - do j = 1,1 - do fc = 1,num_filter - c = filter(fc) - l = col_pp%landunit(c) - if (.not. lun_pp%urbpoi(l)) then - if (j >= col_pp%snl(c)+1) then - if (j == col_pp%snl(c)+1) then - dzp = z(c,j+1)-z(c,j) - bmatrix_soil_snow(c,5,j) = 0._r8 - else if (j == 1) then - ! this is the snow/soil interface layer - dzm = (z(c,j)-z(c,j-1)) - dzp = (z(c,j+1)-z(c,j)) - - bmatrix_soil_snow(c,5,j) = -frac_sno_eff(c) * (1._r8-cnfac) * fact(c,j) & - * tk(c,j-1)/dzm - end if + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_filter + c = filter(fc) + l = col_pp%landunit(c) + if (.not. lun_pp%urbpoi(l)) then + if (j >= col_pp%snl(c)+1) then + if (j == col_pp%snl(c)+1) then + dzp = z(c,j+1)-z(c,j) + bmatrix_soil_snow(c,5,j) = 0._r8 + else if (j == 1) then + ! this is the snow/soil interface layer + dzm = (z(c,j)-z(c,j-1)) + dzp = (z(c,j+1)-z(c,j)) + bmatrix_soil_snow(c,5,j) = -frac_sno_eff(c) * (1._r8-cnfac) * fact(c,j) & + * tk(c,j-1)/dzm end if end if - end do + end if end do end associate @@ -4639,7 +4360,6 @@ subroutine SetMatrix_StandingSurfaceWater(bounds, num_filter, filter, dtime, nba ! Setup the matrix entries corresponding to internal standing water layer ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -4657,7 +4377,7 @@ subroutine SetMatrix_StandingSurfaceWater(bounds, num_filter, filter, dtime, nba real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] real(r8), intent(in) :: dz_h2osfc(bounds%begc: ) ! Thickness of standing water [m] - real(r8), intent(out) :: bmatrix_ssw(bounds%begc: , 1:, 0: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_ssw(bounds%begc: , 1:, 0: ) ! matrix enteries ! ! !LOCAL VARIABLES: integer :: c ! indices @@ -4668,8 +4388,9 @@ subroutine SetMatrix_StandingSurfaceWater(bounds, num_filter, filter, dtime, nba ! Enforce expected array sizes ! Initialize - bmatrix_ssw(bounds%begc:bounds%endc, :, :) = 0.0_r8 + ! bmatrix_ssw(bounds%begc:bounds%endc, :, :) = 0.0_r8 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) @@ -4691,7 +4412,6 @@ subroutine SetMatrix_StandingSurfaceWater_Soil(bounds, num_filter, filter, dtime ! Setup the matrix entries corresponding to standing surface water-soil layer interaction ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -4708,7 +4428,7 @@ subroutine SetMatrix_StandingSurfaceWater_Soil(bounds, num_filter, filter, dtime real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: c_h2osfc( bounds%begc: ) ! heat capacity of surface water [col] real(r8), intent(in) :: dz_h2osfc(bounds%begc: ) ! Thickness of standing water [m] - real(r8), intent(out) :: bmatrix_ssw_soil(bounds%begc: , 1: ,0: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_ssw_soil(bounds%begc: , 1: ,0: ) ! matrix enteries ! ! !LOCAL VARIABLES: integer :: c ! indices @@ -4718,9 +4438,7 @@ subroutine SetMatrix_StandingSurfaceWater_Soil(bounds, num_filter, filter, dtime ! Enforce expected array sizes - ! Initialize - bmatrix_ssw_soil(bounds%begc:bounds%endc, :, :) = 0.0_r8 - + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) @@ -4741,7 +4459,6 @@ subroutine SetMatrix_Soil_StandingSurfaceWater(bounds, num_filter, filter, nband ! Setup the matrix entries corresponding to soil layer-standing surface water interaction ! ! !USES: - !$acc routine seq use elm_varcon , only : cnfac use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall use elm_varpar , only : nlevsno, nlevgrnd @@ -4756,7 +4473,7 @@ subroutine SetMatrix_Soil_StandingSurfaceWater(bounds, num_filter, filter, nband real(r8), intent(in) :: fact( bounds%begc: , -nlevsno+1: ) ! used in computing tridiagonal matrix [col, lev] real(r8), intent(in) :: dz_h2osfc(bounds%begc: ) ! Thickness of standing water [m] real(r8), intent(in) :: frac_h2osfc(bounds%begc: ) ! fractional area with surface water greater than zero - real(r8), intent(out) :: bmatrix_soil_ssw(bounds%begc: , 1:, 1: ) ! matrix enteries + real(r8), intent(inout) :: bmatrix_soil_ssw(bounds%begc: , 1:, 1: ) ! matrix enteries ! ! !LOCAL VARIABLES: integer :: c ! indices @@ -4767,8 +4484,9 @@ subroutine SetMatrix_Soil_StandingSurfaceWater(bounds, num_filter, filter, nband ! Enforce expected array sizes ! Initialize - bmatrix_soil_ssw(bounds%begc:bounds%endc, :, :) = 0.0_r8 + ! bmatrix_soil_ssw(bounds%begc:bounds%endc, :, :) = 0.0_r8 + !$acc parallel loop independent gang vector default(present) do fc = 1,num_filter c = filter(fc) @@ -4786,8 +4504,7 @@ end subroutine SetMatrix_Soil_StandingSurfaceWater !----------------------------------------------------------------------- subroutine Prepare_Data_for_EM_PTM_Driver(bounds, num_filter, filter, & - sabg_lyr, dhsdT, hs_soil, hs_top_snow, hs_h2osfc, & - energyflux_vars) + sabg_lyr, dhsdT, hs_soil, hs_top_snow, hs_h2osfc) ! ! !DESCRIPTION: ! Prepare data needed for the external model, PETSc-based Thermal @@ -4809,7 +4526,6 @@ subroutine Prepare_Data_for_EM_PTM_Driver(bounds, num_filter, filter, & real(r8) , intent(in) :: hs_soil(bounds%begc:bounds%endc) ! heat flux on soil [W/m2] real(r8) , intent(in) :: hs_top_snow(bounds%begc:bounds%endc) ! heat flux on top snow layer [W/m2] real(r8) , intent(in) :: hs_h2osfc(bounds%begc:bounds%endc) ! heat flux on standing water [W/m2] - type(energyflux_type) , intent(inout) :: energyflux_vars ! ! !LOCAL VARIABLES: integer :: c, j diff --git a/components/elm/src/biogeophys/SoilWaterMovementMod.F90 b/components/elm/src/biogeophys/SoilWaterMovementMod.F90 index 6d57e7fc0c5d..1feb09e41099 100644 --- a/components/elm/src/biogeophys/SoilWaterMovementMod.F90 +++ b/components/elm/src/biogeophys/SoilWaterMovementMod.F90 @@ -1,4 +1,4 @@ -module SoilWaterMovementMod + module SoilWaterMovementMod !----------------------------------------------------------------------- ! DESCRIPTION @@ -26,7 +26,7 @@ module SoilWaterMovementMod public :: SoilWater ! Calculate soil hydrology public :: init_soilwater_movement public :: Compute_EffecRootFrac_And_VertTranSink -! public :: Compute_EffecRootFrac_And_VertTranSink_HydStress + ! public :: Compute_EffecRootFrac_And_VertTranSink_HydStress ! ! !PUBLIC DATA MEMBERS: logical, public :: zengdecker_2009_with_var_soil_thick @@ -37,9 +37,6 @@ module SoilWaterMovementMod integer, parameter, public :: vsfm = 1 integer, public :: soilroot_water_method !0: use the Zeng and deck method, this will be readin from namelist in the future - !$acc declare copyin(zengdecker_2009) - !$acc declare copyin(vsfm) - !$acc declare copyin(soilroot_water_method) !----------------------------------------------------------------------- @@ -47,35 +44,33 @@ module SoilWaterMovementMod !----------------------------------------------------------------------- subroutine init_soilwater_movement() - ! - !DESCRIPTION - !specify method for doing soil&root water interactions - ! - use elm_varctl, only : use_vsfm, use_var_soil_thick, use_hydrstress - use spmdMod, only : mpicom, MPI_LOGICAL - use shr_sys_mod,only : shr_sys_abort - ! !ARGUMENTS: - implicit none - integer :: ier ! error status - !------------------------------------------------------------------------------ - soilroot_water_method = zengdecker_2009 - zengdecker_2009_with_var_soil_thick = .false. - - ! GB-FIX-ME: The call to control_spmd() [in subroutine control_init()] before - ! call to init_hydrology() would avoid the mpi broadcast - - call mpi_bcast (use_vsfm, 1, MPI_LOGICAL, 0, mpicom, ier) - if (use_vsfm) soilroot_water_method = vsfm - - call mpi_bcast (use_var_soil_thick, 1, MPI_LOGICAL, 0, mpicom, ier) - if (use_var_soil_thick .and. soilroot_water_method .eq. zengdecker_2009) then - zengdecker_2009_with_var_soil_thick = .true. - end if - - if (use_var_soil_thick .and. soilroot_water_method .ne. zengdecker_2009) then - call shr_sys_abort('ERROR: use_var_soil_thick not supported with anything but zengdecker_2009 at this time.') - end if - + ! + !DESCRIPTION + !specify method for doing soil&root water interactions + ! + use elm_varctl, only : use_vsfm, use_var_soil_thick, use_hydrstress + use spmdMod, only : mpicom, MPI_LOGICAL + use shr_sys_mod,only : shr_sys_abort + ! !ARGUMENTS: + implicit none + integer :: ier ! error status + !------------------------------------------------------------------------------ + soilroot_water_method = zengdecker_2009 + zengdecker_2009_with_var_soil_thick = .false. + + ! GB-FIX-ME: The call to control_spmd() [in subroutine control_init()] before + ! call to init_hydrology() would avoid the mpi broadcast + call mpi_bcast (use_vsfm, 1, MPI_LOGICAL, 0, mpicom, ier) + if (use_vsfm) soilroot_water_method = vsfm + call mpi_bcast (use_var_soil_thick, 1, MPI_LOGICAL, 0, mpicom, ier) + + if (use_var_soil_thick .and. soilroot_water_method .eq. zengdecker_2009) then + zengdecker_2009_with_var_soil_thick = .true. + end if + + if (use_var_soil_thick .and. soilroot_water_method .ne. zengdecker_2009) then + call shr_sys_abort('ERROR: use_var_soil_thick not supported with anything but zengdecker_2009 at this time.') + end if end subroutine init_soilwater_movement !----------------------------------------------------------------------- @@ -86,7 +81,6 @@ subroutine SoilWater(bounds, num_hydrologyc, filter_hydrologyc, & ! select one subroutine to do the soil and root water coupling ! !USES - !$acc routine seq use elm_varctl , only : use_betr use elm_varctl , only : use_var_soil_thick use shr_kind_mod , only : r8 => shr_kind_r8 @@ -110,7 +104,7 @@ subroutine SoilWater(bounds, num_hydrologyc, filter_hydrologyc, & ! ! !LOCAL VARIABLES: !character(len=32) :: subname = 'SoilWater' ! subroutine name - real(r8) :: xs(bounds%begc:bounds%endc) !excess soil water above urban ponding limit + real(r8) :: xs(1:num_hydrologyc) !excess soil water above urban ponding limit integer :: nlevbed ! number of layers to bedrock integer :: fc, c, j @@ -126,6 +120,8 @@ subroutine SoilWater(bounds, num_hydrologyc, filter_hydrologyc, & h2osoi_vol => col_ws%h2osoi_vol , & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) h2osoi_liq => col_ws%h2osoi_liq & ! Output: [real(r8) (:,:) ] liquid water (kg/m2) ) + !$acc enter data create(& + !$acc xs(:)) select case(soilroot_water_method) @@ -136,7 +132,6 @@ subroutine SoilWater(bounds, num_hydrologyc, filter_hydrologyc, & case (vsfm) #ifdef USE_PETSC_LIB -#ifndef _OPENACC call Prepare_Data_for_EM_VSFM_Driver(bounds, num_hydrologyc, filter_hydrologyc, & soilhydrology_vars, soilstate_vars, & waterflux_vars, waterstate_vars, temperature_vars) @@ -148,55 +143,62 @@ subroutine SoilWater(bounds, num_hydrologyc, filter_hydrologyc, & soilhydrology_vars=soilhydrology_vars, soilstate_vars=soilstate_vars, & waterflux_vars=waterflux_vars, waterstate_vars=waterstate_vars, & temperature_vars=temperature_vars) -#endif #endif case default -#ifndef _OPENACC - call endrun('SoilWater' // ':: a SoilWater implementation must be specified!') -#endif + + call endrun('SoilWater' // ':: a SoilWater implementation must be specified!') end select if(use_betr)then !a work around of the negative liquid water embarrassment, which is !critical for a meaningufl tracer transport in betr. Jinyun Tang, Jan 14, 2015 + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed-1 if (h2osoi_liq(c,j) < 0._r8) then - xs(c) = watmin - h2osoi_liq(c,j) + xs(fc) = watmin - h2osoi_liq(c,j) else - xs(c) = 0._r8 + xs(fc) = 0._r8 end if - h2osoi_liq(c,j ) = h2osoi_liq(c,j ) + xs(c) - h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) - xs(c) + h2osoi_liq(c,j ) = h2osoi_liq(c,j ) + xs(fc) + h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) - xs(fc) end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) j = nlev2bed(c) if (h2osoi_liq(c,j) < watmin) then - xs(c) = watmin-h2osoi_liq(c,j) + xs(fc) = watmin-h2osoi_liq(c,j) else - xs(c) = 0._r8 + xs(fc) = 0._r8 end if - h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(c) - wa(c) = wa(c) - xs(c) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + xs(fc) + wa(c) = wa(c) - xs(fc) end do !update volumetric soil moisture for bgc calculation + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) & + h2osoi_ice(c,j)/(dz(c,j)*denice) enddo enddo endif - end associate + + !$acc exit data delete(& + !$acc xs(:)) + + end associate end subroutine SoilWater @@ -205,7 +207,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & num_urbanc, filter_urbanc, soilhydrology_vars, soilstate_vars, dtime) ! ! !DESCRIPTION: - ! Soil hydrology + ! Soil Hydrology ! Soil moisture is predicted from a 10-layer model (as with soil ! temperature), in which the vertical soil moisture transport is governed ! by infiltration, runoff, gradient diffusion, gravity, and root @@ -267,7 +269,6 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! r_j = a_j [d wat_j-1] + b_j [d wat_j] + c_j [d wat_j+1] ! ! !USES: - !$acc routine seq use elm_varctl , only : use_var_soil_thick use shr_kind_mod , only : r8 => shr_kind_r8 use shr_const_mod , only : SHR_CONST_TKFRZ, SHR_CONST_LATICE, SHR_CONST_G @@ -277,7 +278,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & use elm_varpar , only : nlevsoi, max_patch_per_col, nlevgrnd use elm_time_manager , only : get_step_size use column_varcon , only : icol_roof, icol_road_imperv - use TridiagonalMod , only : Tridiagonal + ! use TridiagonalMod , only : Tridiagonal_filter use SoilStateType , only : soilstate_type use SoilHydrologyType , only : soilhydrology_type use VegetationType , only : veg_pp @@ -298,53 +299,54 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! !LOCAL VARIABLES: integer :: p,c,fc,j ! do loop indices integer :: nlevbed ! number of layers to bedrock - integer :: jtop(bounds%begc:bounds%endc) ! top level at each column - integer :: jbot(bounds%begc:bounds%endc) ! bottom level at each column + integer, parameter :: jtop = 1 ! top level at each column + ! integer :: jbot(bounds%begc:bounds%endc) ! bottom level at each column real(r8) :: delta_z_zwt - real(r8) :: hk(bounds%begc:bounds%endc,1:nlevgrnd) ! hydraulic conductivity [mm h2o/s] - real(r8) :: dhkdw(bounds%begc:bounds%endc,1:nlevgrnd) ! d(hk)/d(vol_liq) - real(r8) :: amx(bounds%begc:bounds%endc,1:nlevgrnd+1) ! "a" left off diagonal of tridiagonal matrix - real(r8) :: bmx(bounds%begc:bounds%endc,1:nlevgrnd+1) ! "b" diagonal column for tridiagonal matrix - real(r8) :: cmx(bounds%begc:bounds%endc,1:nlevgrnd+1) ! "c" right off diagonal tridiagonal matrix - real(r8) :: rmx(bounds%begc:bounds%endc,1:nlevgrnd+1) ! "r" forcing term of tridiagonal matrix - real(r8) :: zmm(bounds%begc:bounds%endc,1:nlevgrnd+1) ! layer depth [mm] - real(r8) :: dzmm(bounds%begc:bounds%endc,1:nlevgrnd+1) ! layer thickness [mm] - real(r8) :: den ! used in calculating qin, qout - real(r8) :: dqidw0(bounds%begc:bounds%endc,1:nlevgrnd+1) ! d(qin)/d(vol_liq(i-1)) - real(r8) :: dqidw1(bounds%begc:bounds%endc,1:nlevgrnd+1) ! d(qin)/d(vol_liq(i)) - real(r8) :: dqodw1(bounds%begc:bounds%endc,1:nlevgrnd+1) ! d(qout)/d(vol_liq(i)) - real(r8) :: dqodw2(bounds%begc:bounds%endc,1:nlevgrnd+1) ! d(qout)/d(vol_liq(i+1)) - real(r8) :: dsmpdw(bounds%begc:bounds%endc,1:nlevgrnd+1) ! d(smp)/d(vol_liq) - real(r8) :: num ! used in calculating qin, qout - real(r8) :: qin(bounds%begc:bounds%endc,1:nlevgrnd+1) ! flux of water into soil layer [mm h2o/s] - real(r8) :: qout(bounds%begc:bounds%endc,1:nlevgrnd+1) ! flux of water out of soil layer [mm h2o/s] - real(r8) :: s_node ! soil wetness - real(r8) :: s1 ! "s" at interface of layer - real(r8) :: s2 ! k*s**(2b+2) - real(r8) :: smp(bounds%begc:bounds%endc,1:nlevgrnd) ! soil matrix potential [mm] - real(r8) :: sdamp ! extrapolates soiwat dependence of evaporation - integer :: pi ! pft index - real(r8) :: temp(bounds%begc:bounds%endc) ! accumulator for rootr weighting - integer :: jwt(bounds%begc:bounds%endc) ! index of the soil layer right above the water table (-) + real(r8) :: hk(1:num_hydrologyc,1:nlevgrnd) ! hydraulic conductivity [mm h2o/s] + real(r8) :: dhkdw(1:num_hydrologyc,1:nlevgrnd) ! d(hk)/d(vol_liq) + real(r8) :: amx(1:num_hydrologyc,1:nlevgrnd+1) ! "a" left off diagonal of tridiagonal matrix + real(r8) :: bmx(1:num_hydrologyc,1:nlevgrnd+1) ! "b" diagonal column for tridiagonal matrix + real(r8) :: cmx(1:num_hydrologyc,1:nlevgrnd+1) ! "c" right off diagonal tridiagonal matrix + real(r8) :: rmx(1:num_hydrologyc,1:nlevgrnd+1) ! "r" forcing term of tridiagonal matrix + real(r8) :: zmm(1:num_hydrologyc,1:nlevgrnd+1) ! layer depth [mm] + real(r8) :: dzmm(1:num_hydrologyc,1:nlevgrnd+1) ! layer thickness [mm] + real(r8) :: den ! used in calculating qin, qout + real(r8) :: dqidw0(1:num_hydrologyc,1:nlevgrnd+1) ! d(qin)/d(vol_liq(i-1)) + real(r8) :: dqidw1(1:num_hydrologyc,1:nlevgrnd+1) ! d(qin)/d(vol_liq(i)) + real(r8) :: dqodw1(1:num_hydrologyc,1:nlevgrnd+1) ! d(qout)/d(vol_liq(i)) + real(r8) :: dqodw2(1:num_hydrologyc,1:nlevgrnd+1) ! d(qout)/d(vol_liq(i+1)) + real(r8) :: dsmpdw(1:num_hydrologyc,1:nlevgrnd+1) ! d(smp)/d(vol_liq) + real(r8) :: num ! used in calculating qin, qout + real(r8) :: qin(1:num_hydrologyc,1:nlevgrnd+1) ! flux of water into soil layer [mm h2o/s] + real(r8) :: qout(1:num_hydrologyc,1:nlevgrnd+1) ! flux of water out of soil layer [mm h2o/s] + real(r8) :: s_node ! soil wetness + real(r8) :: s1 ! "s" at interface of layer + real(r8) :: s2 ! k*s**(2b+2) + real(r8) :: smp(1:num_hydrologyc,1:nlevgrnd) ! soil matrix potential [mm] + real(r8) :: sdamp ! extrapolates soiwat dependence of evaporation + integer :: pi ! pft index + integer :: jwt(1:num_hydrologyc) ! index of the soil layer right above the water table (-) real(r8) :: smp1,dsmpdw1,wh,wh_zwt,ka - real(r8) :: dwat2(bounds%begc:bounds%endc,1:nlevgrnd+1) + real(r8) :: dwat2(1:num_hydrologyc,1:nlevgrnd+1) real(r8) :: dzq ! used in calculating qin, qout (difference in equilbirium matric potential) - real(r8) :: zimm(bounds%begc:bounds%endc,0:nlevgrnd) ! layer interface depth [mm] - real(r8) :: zq(bounds%begc:bounds%endc,1:nlevgrnd+1) ! equilibrium matric potential for each layer [mm] - real(r8) :: vol_eq(bounds%begc:bounds%endc,1:nlevgrnd+1) ! equilibrium volumetric water content + real(r8) :: zimm(1:num_hydrologyc,0:nlevgrnd) ! layer interface depth [mm] + real(r8) :: zq(1:num_hydrologyc,1:nlevgrnd+1) ! equilibrium matric potential for each layer [mm] + real(r8) :: vol_eq(1:num_hydrologyc,1:nlevgrnd+1) ! equilibrium volumetric water content real(r8) :: tempi ! temp variable for calculating vol_eq real(r8) :: temp0 ! temp variable for calculating vol_eq real(r8) :: voleq1 ! temp variable for calculating vol_eq - real(r8) :: zwtmm(bounds%begc:bounds%endc) ! water table depth [mm] - real(r8) :: imped(bounds%begc:bounds%endc,1:nlevgrnd) - real(r8) :: vol_ice(bounds%begc:bounds%endc,1:nlevgrnd) + real(r8) :: zwtmm(1:num_hydrologyc) ! water table depth [mm] + real(r8) :: imped(1:num_hydrologyc,1:nlevgrnd) + real(r8) :: vol_ice(1:num_hydrologyc,1:nlevgrnd) real(r8) :: z_mid - real(r8) :: vwc_zwt(bounds%begc:bounds%endc) - real(r8) :: vwc_liq(bounds%begc:bounds%endc,1:nlevgrnd+1) ! liquid volumetric water content - real(r8) :: smp_grad(bounds%begc:bounds%endc,1:nlevgrnd+1) + real(r8) :: vwc_zwt(1:num_hydrologyc) + real(r8) :: vwc_liq(1:num_hydrologyc,1:nlevgrnd+1) ! liquid volumetric water content + ! real(r8) :: smp_grad(bounds%begc:bounds%endc,1:nlevgrnd+1) real(r8) :: dsmpds !temporary variable real(r8) :: dhkds !temporary variable real(r8) :: hktmp !temporary variable + real(r8) :: sum1 + real(r8) :: gam(1:nlevsoi+1),bet !----------------------------------------------------------------------- associate(& @@ -379,52 +381,88 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & qflx_rootsoi_col => col_wf%qflx_rootsoi , & ! Input: [real(r8) (:,:) ] vegetation/soil water exchange (mm H2O/s) (+ = to atm) t_soisno => col_es%t_soisno & ! Input: [real(r8) (:,:) ] soil temperature (Kelvin) ) - - + !$acc enter data create(& + !$acc hk(:,:), & + !$acc dhkdw(:,:), & + !$acc amx(:,:), & + !$acc bmx(:,:), & + !$acc cmx(:,:), & + !$acc rmx(:,:), & + !$acc zmm(:,:), & + !$acc dzmm(:,:), & + !$acc dqidw0(:,:), & + !$acc dqidw1(:,:), & + !$acc dqodw1(:,:), & + !$acc dqodw2(:,:), & + !$acc dsmpdw(:,:), & + !$acc qin(:,:), & + !$acc qout(:,:), & + !$acc smp(:,:), & + !$acc jwt(:), & + !$acc dwat2(:,:), & + !$acc zimm(:,:), & + !$acc zq(:,:), & + !$acc vol_eq(:,:), & + !$acc zwtmm(:), & + !$acc imped(:,:), & + !$acc vol_ice(:,:), & + !$acc vwc_zwt(:), & + !$acc vwc_liq(:,:), & + !$acc gam(:), & + !$acc nlevbed, & + !$acc s_node, & + !$acc s1, & + !$acc smp1, & + !$acc sum1) + + ! Because the depths in this routine are in mm, use local ! variable arrays instead of pointers + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed - zmm(c,j) = z(c,j)*1.e3_r8 - dzmm(c,j) = dz(c,j)*1.e3_r8 - zimm(c,j) = zi(c,j)*1.e3_r8 + zmm(fc,j) = z(c,j)*1.e3_r8 + dzmm(fc,j) = dz(c,j)*1.e3_r8 + zimm(fc,j) = zi(c,j)*1.e3_r8 ! calculate icefrac up here - vol_ice(c,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) - icefrac(c,j) = min(1._r8,vol_ice(c,j)/watsat(c,j)) - vwc_liq(c,j) = max(h2osoi_liq(c,j),1.0e-6_r8)/(dz(c,j)*denh2o) + vol_ice(fc,j) = min(watsat(c,j), h2osoi_ice(c,j)/(dz(c,j)*denice)) + icefrac(c,j) = min(1._r8,vol_ice(fc,j)/watsat(c,j)) + vwc_liq(fc,j) = max(h2osoi_liq(c,j),1.0e-6_r8)/(dz(c,j)*denh2o) end do end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - zimm(c,0) = 0.0_r8 - zwtmm(c) = zwt(c)*1.e3_r8 + zimm(fc,0) = 0.0_r8 + zwtmm(fc) = zwt(c)*1.e3_r8 end do - - - !compute jwt index + ! compute jwt index ! The layer index of the first unsaturated layer, i.e., the layer right above ! the water table - + !$acc parallel loop independent gang worker default(present) present(zwt(:),zi(:,:),vwc_liq(:,:),& + !$acc h2osoi_vol(:,:),watsat(:,:),sucsat(:,:),bsw(:,:)) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) - jwt(c) = nlevbed + jwt(fc) = nlevbed ! allow jwt to equal zero when zwt is in top layer + !$acc loop vector independent do j = 1,nlevbed if (use_var_soil_thick) then if (zwt(c) <= zi(c,j) .and. zwt(c) < zi(c,nlevbed)) then - jwt(c) = j-1 + jwt(fc) = j-1 exit end if else if (zwt(c) <= zi(c,j)) then - jwt(c) = j-1 + jwt(fc) = j-1 exit end if end if @@ -432,17 +470,18 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! compute vwc at water table depth (mainly for case when t < tfrz) ! this will only be used when zwt is below the soil column - vwc_zwt(c) = watsat(c,nlevbed) - if(t_soisno(c,jwt(c)+1) < tfrz) then - vwc_zwt(c) = vwc_liq(c,nlevbed) + vwc_zwt(fc) = watsat(c,nlevbed) + if(t_soisno(c,jwt(fc)+1) < tfrz) then + vwc_zwt(fc) = vwc_liq(fc,nlevbed) + !$acc loop seq do j = nlevbed,nlevgrnd if(zwt(c) <= zi(c,j)) then smp1 = hfus*(tfrz-t_soisno(c,j))/(grav*t_soisno(c,j)) * 1000._r8 !(mm) !smp1 = max(0._r8,smp1) smp1 = max(sucsat(c,nlevsoi),smp1) - vwc_zwt(c) = watsat(c,nlevsoi)*(smp1/sucsat(c,nlevbed))**(-1._r8/bsw(c,nlevsoi)) + vwc_zwt(fc) = watsat(c,nlevsoi)*(smp1/sucsat(c,nlevbed))**(-1._r8/bsw(c,nlevsoi)) ! for temperatures close to tfrz, limit vwc to total water content - vwc_zwt(c) = min(vwc_zwt(c), 0.5*(watsat(c,nlevbed) + h2osoi_vol(c,nlevbed)) ) + vwc_zwt(fc) = min(vwc_zwt(fc), 0.5*(watsat(c,nlevbed) + h2osoi_vol(c,nlevbed)) ) exit endif enddo @@ -451,59 +490,64 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! calculate the equilibrium water content based on the water table depth + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed - if ((zwtmm(c) <= zimm(c,j-1))) then - vol_eq(c,j) = watsat(c,j) + if ((zwtmm(fc) <= zimm(fc,j-1))) then + vol_eq(fc,j) = watsat(c,j) ! use the weighted average from the saturated part (depth > wtd) and the equilibrium solution for the ! rest of the layer, the equilibrium solution is based on Clapp-Hornberg parameterization ! and no extension to full range swrc is needed - else if ((zwtmm(c) .lt. zimm(c,j)) .and. (zwtmm(c) .gt. zimm(c,j-1))) then + else if ((zwtmm(fc) .lt. zimm(fc,j)) .and. (zwtmm(fc) .gt. zimm(fc,j-1))) then tempi = 1.0_r8 - temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) - voleq1 = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zwtmm(c)-zimm(c,j-1))*(tempi-temp0) - vol_eq(c,j) = (voleq1*(zwtmm(c)-zimm(c,j-1)) + watsat(c,j)*(zimm(c,j)-zwtmm(c)))/(zimm(c,j)-zimm(c,j-1)) - vol_eq(c,j) = min(watsat(c,j),vol_eq(c,j)) - vol_eq(c,j) = max(vol_eq(c,j),0.0_r8) + temp0 = (((sucsat(c,j)+zwtmm(fc)-zimm(fc,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) + voleq1 = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zwtmm(fc)-zimm(fc,j-1))*(tempi-temp0) + vol_eq(fc,j) = (voleq1*(zwtmm(fc)-zimm(fc,j-1)) + watsat(c,j)*(zimm(fc,j)-zwtmm(fc)))/(zimm(fc,j)-zimm(fc,j-1)) + vol_eq(fc,j) = min(watsat(c,j),vol_eq(fc,j)) + vol_eq(fc,j) = max(vol_eq(fc,j),0.0_r8) else - tempi = (((sucsat(c,j)+zwtmm(c)-zimm(c,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) - temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) - vol_eq(c,j) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zimm(c,j)-zimm(c,j-1))*(tempi-temp0) - vol_eq(c,j) = max(vol_eq(c,j),0.0_r8) - vol_eq(c,j) = min(watsat(c,j),vol_eq(c,j)) + tempi = (((sucsat(c,j)+zwtmm(fc)-zimm(fc,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) + temp0 = (((sucsat(c,j)+zwtmm(fc)-zimm(fc,j-1))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) + vol_eq(fc,j) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(zimm(fc,j)-zimm(fc,j-1))*(tempi-temp0) + vol_eq(fc,j) = max(vol_eq(fc,j),0.0_r8) + vol_eq(fc,j) = min(watsat(c,j),vol_eq(fc,j)) endif - zq(c,j) = -sucsat(c,j)*(max(vol_eq(c,j)/watsat(c,j),0.01_r8))**(-bsw(c,j)) - zq(c,j) = max(smpmin(c), zq(c,j)) + zq(fc,j) = -sucsat(c,j)*(max(vol_eq(fc,j)/watsat(c,j),0.01_r8))**(-bsw(c,j)) + zq(fc,j) = max(smpmin(c), zq(fc,j)) end do end do ! If water table is below soil column calculate zq for the 11th layer + !$acc parallel loop independent gang vector default(present) do fc=1, num_hydrologyc c = filter_hydrologyc(fc) j = nlev2bed(c) - if(jwt(c) == nlevbed) then + if(jwt(fc) == nlevbed) then tempi = 1._r8 - temp0 = (((sucsat(c,j)+zwtmm(c)-zimm(c,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) - delta_z_zwt = zwtmm(c) - zimm(c,j) + temp0 = (((sucsat(c,j)+zwtmm(fc)-zimm(fc,j))/sucsat(c,j)))**(1._r8-1._r8/bsw(c,j)) + delta_z_zwt = zwtmm(fc) - zimm(fc,j) if(delta_z_zwt == 0._r8) delta_z_zwt = 1._r8 - vol_eq(c,j+1) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(delta_z_zwt)*(tempi-temp0) - vol_eq(c,j+1) = max(vol_eq(c,j+1),0.0_r8) - vol_eq(c,j+1) = min(watsat(c,j),vol_eq(c,j+1)) - zq(c,j+1) = -sucsat(c,j)*(max(vol_eq(c,j+1)/watsat(c,j),0.01_r8))**(-bsw(c,j)) - zq(c,j+1) = max(smpmin(c), zq(c,j+1)) + vol_eq(fc,j+1) = -sucsat(c,j)*watsat(c,j)/(1._r8-1._r8/bsw(c,j))/(delta_z_zwt)*(tempi-temp0) + vol_eq(fc,j+1) = max(vol_eq(fc,j+1),0.0_r8) + vol_eq(fc,j+1) = min(watsat(c,j),vol_eq(fc,j+1)) + zq(fc,j+1) = -sucsat(c,j)*(max(vol_eq(fc,j+1)/watsat(c,j),0.01_r8))**(-bsw(c,j)) + zq(fc,j+1) = max(smpmin(c), zq(fc,j+1)) end if end do ! Hydraulic conductivity and soil matric potential and their derivatives sdamp = 0._r8 + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop vector independent do j = 1, nlevbed ! compute hydraulic conductivity based on liquid water content only @@ -511,7 +555,7 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & s1 = 0.5_r8*(h2osoi_vol(c,j) + h2osoi_vol(c,min(nlevsoi, j+1))) / & (0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) else - s1 = 0.5_r8*(vwc_liq(c,j) + vwc_liq(c,min(nlevsoi, j+1))) / & + s1 = 0.5_r8*(vwc_liq(fc,j) + vwc_liq(fc,min(nlevsoi, j+1))) / & (0.5_r8*(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) endif s1 = min(1._r8, s1) @@ -519,12 +563,12 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! replace fracice with impedance factor, as in zhao 97,99 if (origflag == 1) then - imped(c,j)=(1._r8-0.5_r8*(fracice(c,j)+fracice(c,min(nlevsoi, j+1)))) + imped(fc,j)=(1._r8-0.5_r8*(fracice(c,j)+fracice(c,min(nlevsoi, j+1)))) else - imped(c,j)=10._r8**(-e_ice*(0.5_r8*(icefrac(c,j)+icefrac(c,min(nlevsoi, j+1))))) + imped(fc,j)=10._r8**(-e_ice*(0.5_r8*(icefrac(c,j)+icefrac(c,min(nlevsoi, j+1))))) endif - hk(c,j) = imped(c,j)*s1*s2 - dhkdw(c,j) = imped(c,j)*(2._r8*bsw(c,j)+3._r8)*s2* & + hk(fc,j) = imped(fc,j)*s1*s2 + dhkdw(fc,j) = imped(fc,j)*(2._r8*bsw(c,j)+3._r8)*s2* & (1._r8/(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) !compute un-restricted hydraulic conductivity @@ -536,43 +580,43 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & !hk(c,j) = imped(c,j)*hk(c,j) !dhkdw(c,j) = imped(c,j) * dhkds * (1._r8/(watsat(c,j)+watsat(c,min(nlevsoi, j+1)))) - ! compute matric potential and derivative based on liquid water content only if (origflag == 1) then s_node = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) else - s_node = max(vwc_liq(c,j)/watsat(c,j), 0.01_r8) + s_node = max(vwc_liq(fc,j)/watsat(c,j), 0.01_r8) endif s_node = min(1.0_r8, s_node) !call soil_water_retention_curve%soil_suction(sucsat(c,j), s_node, bsw(c,j), smp(c,j), dsmpds) - smp(c,j) = -sucsat(c,j)*s_node**(-bsw(c,j)) - smp(c,j) = max(smpmin(c), smp(c,j)) + smp(fc,j) = -sucsat(c,j)*s_node**(-bsw(c,j)) + smp(fc,j) = max(smpmin(c), smp(fc,j)) !do not turn on the line below, which will cause bit to bit error, jyt, 2014 Mar 6 !dsmpdw(c,j) = dsmpds/watsat(c,j) if (origflag == 1) then - dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/(s_node*watsat(c,j)) + dsmpdw(fc,j) = -bsw(c,j)*smp(fc,j)/(s_node*watsat(c,j)) else - dsmpdw(c,j) = -bsw(c,j)*smp(c,j)/vwc_liq(c,j) + dsmpdw(fc,j) = -bsw(c,j)*smp(fc,j)/vwc_liq(fc,j) endif - smp_l(c,j) = smp(c,j) - hk_l(c,j) = hk(c,j) + smp_l(c,j) = smp(fc,j) + hk_l(c,j) = hk(fc,j) end do end do ! aquifer (11th) layer + !$acc parallel loop independent gang vector default(present) present(zmm(:,:),dzmm(:,:)) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) - zmm(c,nlevbed+1) = 0.5*(1.e3_r8*zwt(c) + zmm(c,nlevbed)) - if(jwt(c) < nlevbed) then - dzmm(c,nlevbed+1) = dzmm(c,nlevbed) + zmm(fc,nlevbed+1) = 0.5*(1.e3_r8*zwt(c) + zmm(fc,nlevbed)) + if(jwt(fc) < nlevbed) then + dzmm(fc,nlevbed+1) = dzmm(fc,nlevbed) else - dzmm(c,nlevbed+1) = (1.e3_r8*zwt(c) - zmm(c,nlevbed)) + dzmm(fc,nlevbed+1) = (1.e3_r8*zwt(c) - zmm(fc,nlevbed)) end if end do @@ -581,78 +625,82 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! Node j=1 (top) j = 1 + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) - qin(c,j) = qflx_infl(c) - den = (zmm(c,j+1)-zmm(c,j)) - dzq = (zq(c,j+1)-zq(c,j)) - num = (smp(c,j+1)-smp(c,j)) - dzq - qout(c,j) = -hk(c,j)*num/den - dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den - dqodw2(c,j) = -( hk(c,j)*dsmpdw(c,j+1) + num*dhkdw(c,j))/den - rmx(c,j) = qin(c,j) - qout(c,j) - qflx_rootsoi_col(c,j) - amx(c,j) = 0._r8 - bmx(c,j) = dzmm(c,j)*(sdamp+1._r8/dtime) + dqodw1(c,j) - cmx(c,j) = dqodw2(c,j) + qin(fc,j) = qflx_infl(c) + den = (zmm(fc,j+1)-zmm(fc,j)) + dzq = (zq(fc,j+1)-zq(fc,j)) + num = (smp(fc,j+1)-smp(fc,j)) - dzq + qout(fc,j) = -hk(fc,j)*num/den + dqodw1(fc,j) = -(-hk(fc,j)*dsmpdw(fc,j) + num*dhkdw(fc,j))/den + dqodw2(fc,j) = -( hk(fc,j)*dsmpdw(fc,j+1) + num*dhkdw(fc,j))/den + rmx(fc,j) = qin(fc,j) - qout(fc,j) - qflx_rootsoi_col(c,j) + amx(fc,j) = 0._r8 + bmx(fc,j) = dzmm(fc,j)*(sdamp+1._r8/dtime) + dqodw1(fc,j) + cmx(fc,j) = dqodw2(fc,j) end do ! Nodes j=2 to j=nlevsoi-1 + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 2, nlevbed - 1 - den = (zmm(c,j) - zmm(c,j-1)) - dzq = (zq(c,j)-zq(c,j-1)) - num = (smp(c,j)-smp(c,j-1)) - dzq - qin(c,j) = -hk(c,j-1)*num/den - dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den - dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den - den = (zmm(c,j+1)-zmm(c,j)) - dzq = (zq(c,j+1)-zq(c,j)) - num = (smp(c,j+1)-smp(c,j)) - dzq - qout(c,j) = -hk(c,j)*num/den - dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den - dqodw2(c,j) = -( hk(c,j)*dsmpdw(c,j+1) + num*dhkdw(c,j))/den - rmx(c,j) = qin(c,j) - qout(c,j) - qflx_rootsoi_col(c,j) - amx(c,j) = -dqidw0(c,j) - bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j) - cmx(c,j) = dqodw2(c,j) + den = (zmm(fc,j) - zmm(fc,j-1)) + dzq = (zq(fc,j)-zq(fc,j-1)) + num = (smp(fc,j)-smp(fc,j-1)) - dzq + qin(fc,j) = -hk(fc,j-1)*num/den + dqidw0(fc,j) = -(-hk(fc,j-1)*dsmpdw(fc,j-1) + num*dhkdw(fc,j-1))/den + dqidw1(fc,j) = -( hk(fc,j-1)*dsmpdw(fc,j) + num*dhkdw(fc,j-1))/den + den = (zmm(fc,j+1)-zmm(fc,j)) + dzq = (zq(fc,j+1)-zq(fc,j)) + num = (smp(fc,j+1)-smp(fc,j)) - dzq + qout(fc,j) = -hk(fc,j)*num/den + dqodw1(fc,j) = -(-hk(fc,j)*dsmpdw(fc,j) + num*dhkdw(fc,j))/den + dqodw2(fc,j) = -( hk(fc,j)*dsmpdw(fc,j+1) + num*dhkdw(fc,j))/den + rmx(fc,j) = qin(fc,j) - qout(fc,j) - qflx_rootsoi_col(c,j) + amx(fc,j) = -dqidw0(fc,j) + bmx(fc,j) = dzmm(fc,j)/dtime - dqidw1(fc,j) + dqodw1(fc,j) + cmx(fc,j) = dqodw2(fc,j) end do end do ! Node j=nlevsoi (bottom) + !$acc parallel loop independent gang vector default(present) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) j = nlevbed - if(j > jwt(c)) then !water table is in soil column - den = (zmm(c,j) - zmm(c,j-1)) - dzq = (zq(c,j)-zq(c,j-1)) - num = (smp(c,j)-smp(c,j-1)) - dzq - qin(c,j) = -hk(c,j-1)*num/den - dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den - dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den - qout(c,j) = 0._r8 - dqodw1(c,j) = 0._r8 - rmx(c,j) = qin(c,j) - qout(c,j) - qflx_rootsoi_col(c,j) - amx(c,j) = -dqidw0(c,j) - bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j) - cmx(c,j) = 0._r8 + if(j > jwt(fc)) then !water table is in soil column + den = (zmm(fc,j) - zmm(fc,j-1)) + dzq = (zq(fc,j)-zq(fc,j-1)) + num = (smp(fc,j)-smp(fc,j-1)) - dzq + qin(fc,j) = -hk(fc,j-1)*num/den + dqidw0(fc,j) = -(-hk(fc,j-1)*dsmpdw(fc,j-1) + num*dhkdw(fc,j-1))/den + dqidw1(fc,j) = -( hk(fc,j-1)*dsmpdw(fc,j) + num*dhkdw(fc,j-1))/den + qout(fc,j) = 0._r8 + dqodw1(fc,j) = 0._r8 + rmx(fc,j) = qin(fc,j) - qout(fc,j) - qflx_rootsoi_col(c,j) + amx(fc,j) = -dqidw0(fc,j) + bmx(fc,j) = dzmm(fc,j)/dtime - dqidw1(fc,j) + dqodw1(fc,j) + cmx(fc,j) = 0._r8 ! next set up aquifer layer; hydrologically inactive - rmx(c,j+1) = 0._r8 - amx(c,j+1) = 0._r8 - bmx(c,j+1) = dzmm(c,j+1)/dtime - cmx(c,j+1) = 0._r8 + rmx(fc,j+1) = 0._r8 + amx(fc,j+1) = 0._r8 + bmx(fc,j+1) = dzmm(fc,j+1)/dtime + cmx(fc,j+1) = 0._r8 else ! water table is below soil column ! compute aquifer soil moisture as average of layer 10 and saturation if(origflag == 1) then s_node = max(0.5*(1.0_r8+h2osoi_vol(c,j)/watsat(c,j)), 0.01_r8) else - s_node = max(0.5*((vwc_zwt(c)+vwc_liq(c,j))/watsat(c,j)), 0.01_r8) + s_node = max(0.5*((vwc_zwt(fc)+vwc_liq(fc,j))/watsat(c,j)), 0.01_r8) endif s_node = min(1.0_r8, s_node) @@ -666,103 +714,132 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & dsmpdw1 = -bsw(c,j)*smp1/(s_node*watsat(c,j)) ! first set up bottom layer of soil column - den = (zmm(c,j) - zmm(c,j-1)) - dzq = (zq(c,j)-zq(c,j-1)) - num = (smp(c,j)-smp(c,j-1)) - dzq - qin(c,j) = -hk(c,j-1)*num/den - dqidw0(c,j) = -(-hk(c,j-1)*dsmpdw(c,j-1) + num*dhkdw(c,j-1))/den - dqidw1(c,j) = -( hk(c,j-1)*dsmpdw(c,j) + num*dhkdw(c,j-1))/den - den = (zmm(c,j+1)-zmm(c,j)) - dzq = (zq(c,j+1)-zq(c,j)) - num = (smp1-smp(c,j)) - dzq + den = (zmm(fc,j) - zmm(fc,j-1)) + dzq = (zq(fc,j)-zq(fc,j-1)) + num = (smp(fc,j)-smp(fc,j-1)) - dzq + qin(fc,j) = -hk(fc,j-1)*num/den + dqidw0(fc,j) = -(-hk(fc,j-1)*dsmpdw(fc,j-1) + num*dhkdw(fc,j-1))/den + dqidw1(fc,j) = -( hk(fc,j-1)*dsmpdw(fc,j) + num*dhkdw(fc,j-1))/den + den = (zmm(fc,j+1)-zmm(fc,j)) + dzq = (zq(fc,j+1)-zq(fc,j)) + num = (smp1-smp(fc,j)) - dzq if (use_var_soil_thick) then - qout(c,j) = 0._r8 - dqodw1(c,j) = 0._r8 - dqodw2(c,j) = 0._r8 + qout(fc,j) = 0._r8 + dqodw1(fc,j) = 0._r8 + dqodw2(fc,j) = 0._r8 else - qout(c,j) = -hk(c,j)*num/den - dqodw1(c,j) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den - dqodw2(c,j) = -( hk(c,j)*dsmpdw1 + num*dhkdw(c,j))/den + qout(fc,j) = -hk(fc,j)*num/den + dqodw1(fc,j) = -(-hk(fc,j)*dsmpdw(fc,j) + num*dhkdw(fc,j))/den + dqodw2(fc,j) = -( hk(fc,j)*dsmpdw1 + num*dhkdw(fc,j))/den end if - rmx(c,j) = qin(c,j) - qout(c,j) - qflx_rootsoi_col(c,j) - amx(c,j) = -dqidw0(c,j) - bmx(c,j) = dzmm(c,j)/dtime - dqidw1(c,j) + dqodw1(c,j) - cmx(c,j) = dqodw2(c,j) + rmx(fc,j) = qin(fc,j) - qout(fc,j) - qflx_rootsoi_col(c,j) + amx(fc,j) = -dqidw0(fc,j) + bmx(fc,j) = dzmm(fc,j)/dtime - dqidw1(fc,j) + dqodw1(fc,j) + cmx(fc,j) = dqodw2(fc,j) ! next set up aquifer layer; den/num unchanged, qin=qout - qin(c,j+1) = qout(c,j) - dqidw0(c,j+1) = -(-hk(c,j)*dsmpdw(c,j) + num*dhkdw(c,j))/den - dqidw1(c,j+1) = -( hk(c,j)*dsmpdw1 + num*dhkdw(c,j))/den - qout(c,j+1) = 0._r8 ! zero-flow bottom boundary condition - dqodw1(c,j+1) = 0._r8 ! zero-flow bottom boundary condition + qin(fc,j+1) = qout(fc,j) + dqidw0(fc,j+1) = -(-hk(fc,j)*dsmpdw(fc,j) + num*dhkdw(fc,j))/den + dqidw1(fc,j+1) = -( hk(fc,j)*dsmpdw1 + num*dhkdw(fc,j))/den + qout(fc,j+1) = 0._r8 ! zero-flow bottom boundary condition + dqodw1(fc,j+1) = 0._r8 ! zero-flow bottom boundary condition if (use_var_soil_thick) then - rmx(c,j+1) = 0._r8 - amx(c,j+1) = 0._r8 - bmx(c,j+1) = dzmm(c,j+1)/dtime - cmx(c,j+1) = 0._r8 + rmx(fc,j+1) = 0._r8 + amx(fc,j+1) = 0._r8 + bmx(fc,j+1) = dzmm(fc,j+1)/dtime + cmx(fc,j+1) = 0._r8 else - rmx(c,j+1) = qin(c,j+1) - qout(c,j+1) - amx(c,j+1) = -dqidw0(c,j+1) - bmx(c,j+1) = dzmm(c,j+1)/dtime - dqidw1(c,j+1) + dqodw1(c,j+1) - cmx(c,j+1) = 0._r8 + rmx(fc,j+1) = qin(fc,j+1) - qout(fc,j+1) + amx(fc,j+1) = -dqidw0(fc,j+1) + bmx(fc,j+1) = dzmm(fc,j+1)/dtime - dqidw1(fc,j+1) + dqodw1(fc,j+1) + cmx(fc,j+1) = 0._r8 end if endif end do ! Solve for dwat - - jtop(bounds%begc : bounds%endc) = 1 ! Determination of how many layers (nlev2bed) to do for the tridiagonal ! at each column if (use_var_soil_thick) then - do fc = 1,num_hydrologyc - c = filter_hydrologyc(fc) - jbot(c) = nlev2bed(c) - end do - call Tridiagonal(bounds, 1, nlevgrnd+1, & - jtop(bounds%begc:bounds%endc), & - jbot(bounds%begc:bounds%endc), & - num_hydrologyc, filter_hydrologyc, & - amx(bounds%begc:bounds%endc, :), & - bmx(bounds%begc:bounds%endc, :), & - cmx(bounds%begc:bounds%endc, :), & - rmx(bounds%begc:bounds%endc, :), & - dwat2(bounds%begc:bounds%endc, :) ) + ! !$acc parallel loop independent gang vector default(present) + ! do fc = 1,num_hydrologyc + ! c = filter_hydrologyc(fc) + ! jbot(c) = nlev2bed(c) + ! end do + ! call Tridiagonal(bounds, 1, nlevgrnd+1, & + ! jtop(bounds%begc:bounds%endc), & + ! jbot(bounds%begc:bounds%endc), & + ! num_hydrologyc, filter_hydrologyc, & + ! amx(bounds%begc:bounds%endc, :), & + ! bmx(bounds%begc:bounds%endc, :), & + ! cmx(bounds%begc:bounds%endc, :), & + ! rmx(bounds%begc:bounds%endc, :), & + ! dwat2(bounds%begc:bounds%endc, :) ) else - call Tridiagonal(bounds, 1, nlevsoi+1, & - jtop(bounds%begc:bounds%endc), & - num_hydrologyc, filter_hydrologyc, & - amx(bounds%begc:bounds%endc, :), & - bmx(bounds%begc:bounds%endc, :), & - cmx(bounds%begc:bounds%endc, :), & - rmx(bounds%begc:bounds%endc, :), & - dwat2(bounds%begc:bounds%endc, :) ) + ! call Tridiagonal_filter(1, nlevsoi+1, & + ! jtop, num_hydrologyc, filter_hydrologyc, & + ! amx(1:num_hydrologyc, :), & + ! bmx(1:num_hydrologyc, :), & + ! cmx(1:num_hydrologyc, :), & + ! rmx(1:num_hydrologyc, :), & + ! dwat2(1:num_hydrologyc, :) ) + + !$acc parallel loop independent gang vector default(present) create(gam(:)) private(bet,gam(:)) + do fc = 1,num_hydrologyc + bet = bmx(fc,jtop) + + !$acc loop seq + do j = 1, nlevsoi+1 + if (j >= jtop) then + if (j == jtop) then + dwat2(fc,j) = rmx(fc,j) / bet + else + gam(j) = cmx(fc,j-1) / bet + bet = bmx(fc,j) - amx(fc,j) * gam(j) + dwat2(fc,j) = (rmx(fc,j) - amx(fc,j)*dwat2(fc,j-1)) / bet + end if + end if + end do + + !$acc loop seq + do j = nlevsoi,1,-1 + if (j >= jtop) then + dwat2(fc,j) = dwat2(fc,j) - gam(j+1) * dwat2(fc,j+1) + end if + end do + end do end if ! Renew the mass of liquid water ! also compute qcharge from dwat in aquifer layer ! update in drainage for case jwt < nlevsoi - + !$acc parallel loop independent gang worker default(present) do fc = 1,num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) + !$acc loop vector independent do j = 1, nlevbed - h2osoi_liq(c,j) = h2osoi_liq(c,j) + dwat2(c,j)*dzmm(c,j) + h2osoi_liq(c,j) = h2osoi_liq(c,j) + dwat2(fc,j)*dzmm(fc,j) end do + end do + + ! calculate qcharge for case jwt < nlevsoi + if (use_var_soil_thick) then + !$acc parallel loop independent gang vector default(present) + do fc = 1,num_hydrologyc + c = filter_hydrologyc(fc) - ! calculate qcharge for case jwt < nlevsoi - if (use_var_soil_thick) then - if (jwt(c) < nlevbed) then + if (jwt(fc) < nlevbed) then wh_zwt = 0._r8 !since wh_zwt = -sucsat - zq_zwt, where zq_zwt = -sucsat ! Recharge rate qcharge to groundwater (positive to aquifer) - s_node = max(h2osoi_vol(c,jwt(c)+1)/watsat(c,jwt(c)+1), 0.01_r8) + s_node = max(h2osoi_vol(c,jwt(fc)+1)/watsat(c,jwt(fc)+1), 0.01_r8) s1 = min(1._r8, s_node) !scs: this is the expression for unsaturated hk - ka = imped(c,jwt(c)+1)*hksat(c,jwt(c)+1) & - *s1**(2._r8*bsw(c,jwt(c)+1)+3._r8) + ka = imped(fc,jwt(fc)+1)*hksat(c,jwt(fc)+1) & + *s1**(2._r8*bsw(c,jwt(fc)+1)+3._r8) !compute unsaturated hk, this shall be tested later, because it !is not bit for bit @@ -770,16 +847,16 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & !apply ice impedance !ka = imped(c,jwt(c)+1) * ka ! Recharge rate qcharge to groundwater (positive to aquifer) - smp1 = max(smpmin(c), smp(c,max(1,jwt(c)))) - wh = smp1 - zq(c,max(1,jwt(c))) + smp1 = max(smpmin(c), smp(fc,max(1,jwt(fc)))) + wh = smp1 - zq(fc,max(1,jwt(fc))) !scs: original formulation - if (jwt(c) == 0) then + if (jwt(fc) == 0) then qcharge(c) = -ka * (wh_zwt-wh) /((zwt(c)+1.e-3)*1000._r8) else ! qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8) !scs: 1/2, assuming flux is at zwt interface, saturation deeper than zwt - qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8*2.0) + qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(fc)))*1000._r8*2.0) endif ! To limit qcharge (for the first several timesteps) @@ -789,17 +866,23 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & ! if water table is below soil column, compute qcharge from dwat2(11) qcharge(c) = 0._r8 endif - else - if (jwt(c) < nlevbed) then + end do + + else !use_var_soil_thick + !$acc parallel loop independent gang vector default(present) & + !$acc present(imped(:,:),hksat(:,:),h2osoi_vol(:,:),watsat(:,:),smp(:,:),zq(:,:),z(:,:),bsw(:,:)) + do fc = 1,num_hydrologyc + c = filter_hydrologyc(fc) + if (jwt(fc) < nlevbed) then wh_zwt = 0._r8 !since wh_zwt = -sucsat - zq_zwt, where zq_zwt = -sucsat ! Recharge rate qcharge to groundwater (positive to aquifer) - s_node = max(h2osoi_vol(c,jwt(c)+1)/watsat(c,jwt(c)+1), 0.01_r8) + s_node = max(h2osoi_vol(c,jwt(fc)+1)/watsat(c,jwt(fc)+1), 0.01_r8) s1 = min(1._r8, s_node) !scs: this is the expression for unsaturated hk - ka = imped(c,jwt(c)+1)*hksat(c,jwt(c)+1) & - *s1**(2._r8*bsw(c,jwt(c)+1)+3._r8) + ka = imped(fc,jwt(fc)+1)*hksat(c,jwt(fc)+1) & + *s1**(2._r8*bsw(c,jwt(fc)+1)+3._r8) !compute unsaturated hk, this shall be tested later, because it !is not bit for bit @@ -807,16 +890,16 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & !apply ice impedance !ka = imped(c,jwt(c)+1) * ka ! Recharge rate qcharge to groundwater (positive to aquifer) - smp1 = max(smpmin(c), smp(c,max(1,jwt(c)))) - wh = smp1 - zq(c,max(1,jwt(c))) + smp1 = max(smpmin(c), smp(fc,max(1,jwt(fc)))) + wh = smp1 - zq(fc,max(1,jwt(fc))) !scs: original formulation - if (jwt(c) == 0) then + if (jwt(fc) == 0) then qcharge(c) = -ka * (wh_zwt-wh) /((zwt(c)+1.e-3)*1000._r8) else ! qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8) !scs: 1/2, assuming flux is at zwt interface, saturation deeper than zwt - qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(c)))*1000._r8*2.0) + qcharge(c) = -ka * (wh_zwt-wh)/((zwt(c)-z(c,jwt(fc)))*1000._r8*2.0) endif ! To limit qcharge (for the first several timesteps) @@ -824,25 +907,62 @@ subroutine soilwater_zengdecker2009(bounds, num_hydrologyc, filter_hydrologyc, & qcharge(c) = min( 10.0_r8/dtime,qcharge(c)) else ! if water table is below soil column, compute qcharge from dwat2(11) - qcharge(c) = dwat2(c,nlevsoi+1)*dzmm(c,nlevsoi+1)/dtime + qcharge(c) = dwat2(fc,nlevsoi+1)*dzmm(fc,nlevsoi+1)/dtime endif - endif - end do + end do + endif !use_var_soil_thick ! compute the water deficit and reset negative liquid water content ! Jinyun Tang + !$acc parallel loop independent gang worker default(present) private(sum1) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) nlevbed = nlev2bed(c) - qflx_deficit(c) = 0._r8 + sum1 = 0._r8 + !$acc loop vector reduction(+:sum1) do j = 1, nlevbed if(h2osoi_liq(c,j)<0._r8)then - qflx_deficit(c) = qflx_deficit(c) - h2osoi_liq(c,j) + sum1 = sum1 - h2osoi_liq(c,j) endif enddo - enddo - - end associate + qflx_deficit(c) = sum1 + enddo + + !$acc exit data delete(& + !$acc hk(:,:), & + !$acc dhkdw(:,:), & + !$acc amx(:,:), & + !$acc bmx(:,:), & + !$acc cmx(:,:), & + !$acc rmx(:,:), & + !$acc zmm(:,:), & + !$acc dzmm(:,:), & + !$acc dqidw0(:,:), & + !$acc dqidw1(:,:), & + !$acc dqodw1(:,:), & + !$acc dqodw2(:,:), & + !$acc dsmpdw(:,:), & + !$acc qin(:,:), & + !$acc qout(:,:), & + !$acc smp(:,:), & + !$acc jwt(:), & + !$acc dwat2(:,:), & + !$acc zimm(:,:), & + !$acc zq(:,:), & + !$acc vol_eq(:,:), & + !$acc zwtmm(:), & + !$acc imped(:,:), & + !$acc vol_ice(:,:), & + !$acc vwc_zwt(:), & + !$acc vwc_liq(:,:), & + !$acc gam(:), & + !$acc nlevbed, & + !$acc s_node, & + !$acc s1, & + !$acc smp1, & + !$acc sum1) + + end associate end subroutine soilwater_zengdecker2009 @@ -1045,7 +1165,7 @@ end subroutine Prepare_Data_for_EM_VSFM_Driver ! ==================================================================================== subroutine Compute_EffecRootFrac_And_VertTranSink(bounds, num_hydrologyc, & - filter_hydrologyc, soilstate_inst, canopystate_inst, energyflux_inst) + filter_hydrologyc, soilstate_inst, canopystate_inst) ! --------------------------------------------------------------------------------- ! This is a wrapper for calculating the effective root fraction and soil @@ -1066,11 +1186,8 @@ subroutine Compute_EffecRootFrac_And_VertTranSink(bounds, num_hydrologyc, & ! ! ! --------------------------------------------------------------------------------- - - !$acc routine seq use SoilStateType , only : soilstate_type use CanopyStateType , only : canopystate_type - use EnergyFluxType , only : energyflux_type use ColumnType , only : col_pp use LandunitType , only : lun_pp use decompMod , only : bounds_type @@ -1083,65 +1200,77 @@ subroutine Compute_EffecRootFrac_And_VertTranSink(bounds, num_hydrologyc, & integer , intent(in) :: filter_hydrologyc(num_hydrologyc) ! column filter for soil points type(soilstate_type) , intent(inout) :: soilstate_inst type(canopystate_type) , intent(in) :: canopystate_inst - type(energyflux_type) , intent(in) :: energyflux_inst ! Local Variables - integer :: filterc(bounds%endc-bounds%begc+1) !column filter + integer :: filterc(1:num_hydrologyc) !column filter integer :: num_filterc integer :: num_filterc_tot integer :: fc integer :: c - integer :: l + integer :: l, fperv, fimperv - num_filterc_tot = 0 + !$acc enter data create(& + !$acc filterc(:), fperv, fimperv) + + num_filterc_tot = 0 ! 1) pervious roads num_filterc = 0 + !$acc parallel loop independent gang vector present(filterc(:)) private(c,fperv) copy(num_filterc) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) if (col_pp%itype(c) == icol_road_perv) then + !$acc atomic capture num_filterc = num_filterc + 1 - filterc(num_filterc) = c + fperv = num_filterc + !$acc end atomic + filterc(fperv) = c end if end do num_filterc_tot = num_filterc_tot+num_filterc + call Compute_EffecRootFrac_And_VertTranSink_Default(bounds, & - num_filterc,filterc, soilstate_inst ) - - + num_filterc, filterc, soilstate_inst ) + num_filterc = 0 + !$acc parallel loop independent gang vector default(present) present(filterc(:)) private(c,l,fimperv) copy(num_filterc) do fc = 1, num_hydrologyc c = filter_hydrologyc(fc) l = col_pp%landunit(c) if ( (col_pp%itype(c) /= icol_road_perv) ) then + !$acc atomic capture num_filterc = num_filterc + 1 - filterc(num_filterc) = c + fimperv = num_filterc + !$acc end atomic + filterc(fimperv) = c end if end do num_filterc_tot = num_filterc_tot+num_filterc + if(use_hydrstress) then call Compute_EffecRootFrac_And_VertTranSink_HydStress(bounds, & num_filterc, filterc, soilstate_inst, & - canopystate_inst, energyflux_inst) + canopystate_inst) else call Compute_EffecRootFrac_And_VertTranSink_Default(bounds, & - num_filterc,filterc, soilstate_inst) + num_filterc,filterc, soilstate_inst) end if if (num_hydrologyc /= num_filterc_tot) then - write(iulog,*) 'The total number of columns flagged to root water uptake' - write(iulog,*) 'did not match the total number calculated' - write(iulog,*) 'This is likely a problem with the interpretation of column/lu filters.' + write(*,*) 'The total number of columns flagged to root water uptake' + write(*,*) 'did not match the total number calculated' + write(*,*) 'This is likely a problem with the interpretation of column/lu filters.' call endrun(msg=errMsg(__FILE__, __LINE__)) + stop end if + !$acc exit data delete(& + !$acc filterc(:), fperv, fimperv) - return end subroutine Compute_EffecRootFrac_And_VertTranSink subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & filterc, soilstate_vars) - ! ! Generic routine to apply transpiration as a sink condition that ! is vertically distributed over the soil column. Should be @@ -1149,7 +1278,6 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & ! hydraulics. ! !USES: - !$acc routine seq use decompMod , only : bounds_type use shr_kind_mod , only : r8 => shr_kind_r8 use elm_varpar , only : nlevsoi, max_patch_per_col @@ -1160,14 +1288,16 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds ! bounds integer , intent(in) :: num_filterc ! number of column soil points in column filter - integer , intent(in) :: filterc(num_filterc) ! column filter for soil points + integer , intent(in) :: filterc(1:num_filterc) ! column filter for soil points type(soilstate_type) , intent(inout) :: soilstate_vars ! ! !LOCAL VARIABLES: integer :: p,c,fc,j ! do loop indices integer :: pi ! patch index integer :: nlevbed ! number of layers to bedrock - real(r8) :: temp(bounds%begc:bounds%endc) ! accumulator for rootr weighting + real(r8) :: temp(1:num_filterc) ! accumulator for rootr weighting + real(r8) :: sum1, sum2 + integer :: nlevbed_max associate(& nlev2bed => col_pp%nlevbed , & ! Input: [integer (:) ] number of layers to bedrock qflx_rootsoi_col => col_wf%qflx_rootsoi , & ! Output: [real(r8) (:,:) ] @@ -1182,6 +1312,10 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & rootr_col => soilstate_vars%rootr_col & ! Output: [real(r8) (:,:) ] ! effective fraction of roots in each soil layer ) + + !$acc enter data create(& + !$acc temp(:), & + !$acc sum1) ! First step is to calculate the column-level effective rooting ! fraction in each soil layer. This is done outside the usual @@ -1189,84 +1323,90 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_Default(bounds, num_filterc, & ! weighted average of the PATCH level rootr arrays. Instead, the ! weighting depends on both the per-unit-area transpiration ! of the PATCH and the PATCHEs area relative to all PATCHES. - - temp(bounds%begc : bounds%endc) = 0._r8 - - do fc = 1, num_filterc - c = filterc(fc) - nlevbed = nlev2bed(c) - do j = 1, nlevbed - rootr_col(c,j) = 0._r8 - end do - end do - - do pi = 1,max_patch_per_col + nlevbed_max = maxval(nlev2bed) + !$acc parallel loop independent gang worker collapse(2) default(present) private(sum1) + do j = 1,nlevbed_max do fc = 1, num_filterc c = filterc(fc) nlevbed = nlev2bed(c) - do j = 1,nlevbed - if (pi <= col_pp%npfts(c)) then - p = col_pp%pfti(c) + pi - 1 - if (veg_pp%active(p)) then - rootr_col(c,j) = rootr_col(c,j) + rootr_patch(p,j) * & - qflx_tran_veg_patch(p) * veg_pp%wtcol(p) - qflx_rootsoi_frac_patch(p,j) = rootr_patch(p,j) * qflx_tran_veg_patch(p) * veg_pp%wtcol(p) - end if - end if - end do - end do - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col_pp%npfts(c)) then - p = col_pp%pfti(c) + pi - 1 + + if(j > nlev2bed(c)) cycle + sum1 = 0._r8; + !$acc loop vector reduction(+:sum1) + do p = col_pp%pfti(c), col_pp%pftf(c) if (veg_pp%active(p)) then - temp(c) = temp(c) + qflx_tran_veg_patch(p) * veg_pp%wtcol(p) + sum1 = sum1 + rootr_patch(p,j) * qflx_tran_veg_patch(p) * veg_pp%wtcol(p) + qflx_rootsoi_frac_patch(p,j) = rootr_patch(p,j) * qflx_tran_veg_patch(p) * veg_pp%wtcol(p) end if - end if + end do + rootr_col(c,j) = sum1 end do end do + !$acc parallel loop independent gang worker default(present) private(sum1) + do fc = 1, num_filterc + c = filterc(fc) + sum1 = 0._r8; + !$acc loop vector reduction(+:sum1) + do p = col_pp%pfti(c), col_pp%pftf(c) + if (veg_pp%active(p)) then + sum1 = sum1 + qflx_tran_veg_patch(p) * veg_pp%wtcol(p) + end if + end do + temp(fc) = sum1 + end do + + !$acc parallel loop independent gang vector default(present) do fc = 1, num_filterc c = filterc(fc) nlevbed = nlev2bed(c) + !$acc loop seq do j = 1, nlevbed - if (temp(c) /= 0._r8) then - rootr_col(c,j) = rootr_col(c,j)/temp(c) + if (temp(fc) /= 0._r8) then + rootr_col(c,j) = rootr_col(c,j)/temp(fc) end if qflx_rootsoi_col(c,j) = rootr_col(c,j)*qflx_tran_veg_col(c) end do end do - - do pi = 1,max_patch_per_col - do j = 1,nlevsoi - do fc = 1, num_filterc - c = filterc(fc) - if (pi <= col_pp%npfts(c)) then - p = col_pp%pfti(c) + pi - 1 + + !$acc parallel loop independent gang worker collapse(2) default(present) + do j = 1,nlevsoi + do fc = 1, num_filterc + c = filterc(fc) + if(rootr_col(c,j)==0._r8)then + !$acc loop vector independent + do p = col_pp%pfti(c), col_pp%pftf(c) if (veg_pp%active(p)) then - if(rootr_col(c,j)==0._r8)then qflx_rootsoi_frac_patch(p,j) = 0._r8 - else - qflx_rootsoi_frac_patch(p,j) = qflx_rootsoi_frac_patch(p,j)/(temp(c)*rootr_col(c,j)) - endif end if - end if - end do + end do + else + !$acc loop vector independent + do p = col_pp%pfti(c), col_pp%pftf(c) + if (veg_pp%active(p)) then + qflx_rootsoi_frac_patch(p,j) = qflx_rootsoi_frac_patch(p,j)*(1._r8/(temp(fc)*rootr_col(c,j))) + end if + end do + end if end do - enddo - end associate - return + end do + + !$acc exit data delete(& + !$acc temp(:), & + !$acc sum1) + + end associate + end subroutine Compute_EffecRootFrac_And_VertTranSink_Default ! ================================================================================== subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress( bounds, & num_filterc, filterc, soilstate_vars, & - canopystate_vars, energyflux_vars) + canopystate_vars) ! !USES: - !$acc routine seq use decompMod , only : bounds_type use elm_varpar , only : nlevsoi use elm_varpar , only : max_patch_per_col @@ -1277,8 +1417,6 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress( bounds, & use elm_varctl , only : iulog use PhotosynthesisMod, only : plc, params_inst use column_varcon , only : icol_road_perv - use shr_infnan_mod , only : isnan => shr_infnan_isnan - use EnergyFluxType , only : energyflux_type use shr_kind_mod , only : r8 => shr_kind_r8 ! ! !ARGUMENTS: @@ -1287,7 +1425,6 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress( bounds, & integer , intent(in) :: filterc(:) ! column filter for soil points type(soilstate_type) , intent(inout) :: soilstate_vars type(canopystate_type) , intent(in) :: canopystate_vars - type(energyflux_type), intent(in) :: energyflux_vars ! ! !LOCAL VARIABLES: integer :: p,c,fc,j ! do loop indices @@ -1356,8 +1493,6 @@ subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress( bounds, & end do end associate - - return end subroutine Compute_EffecRootFrac_And_VertTranSink_HydStress diff --git a/components/elm/src/biogeophys/SurfaceAlbedoMod.F90 b/components/elm/src/biogeophys/SurfaceAlbedoMod.F90 index f36f74411fb5..4c2d7a12ac87 100644 --- a/components/elm/src/biogeophys/SurfaceAlbedoMod.F90 +++ b/components/elm/src/biogeophys/SurfaceAlbedoMod.F90 @@ -135,8 +135,8 @@ subroutine SurfaceAlbedo(bounds, & real(r8) :: ws (bounds%begp:bounds%endp) ! fraction of LAI+SAI that is SAI real(r8) :: blai(bounds%begp:bounds%endp) ! lai buried by snow: tlai - elai real(r8) :: bsai(bounds%begp:bounds%endp) ! sai buried by snow: tsai - esai - real(r8) :: sza,saa,deg2rad,slope_rad,aspect_rad - + real(r8) :: sza,saa,slope_rad,aspect_rad + real(r8), parameter :: deg2rad = SHR_CONST_PI/180._r8 real(r8) :: coszen_gcell (bounds%begg:bounds%endg) ! cosine solar zenith angle for next time step (grc) real(r8) :: coszen_patch (bounds%begp:bounds%endp) ! cosine solar zenith angle for next time step (pft) real(r8) :: cosinc_gcell (bounds%begg:bounds%endg) ! cosine solar incidence angle to local surface for next time step (grc) @@ -241,7 +241,6 @@ subroutine SurfaceAlbedo(bounds, & ! Cosine solar zenith angle for next time step - deg2rad = SHR_CONST_PI/180._r8 if (.not. use_finetop_rad) then do g = bounds%begg,bounds%endg coszen_gcell(g) = shr_orb_cosz (nextsw_cday, grc_pp%lat(g), grc_pp%lon(g), declinp1) @@ -332,8 +331,8 @@ subroutine SurfaceAlbedo(bounds, & call SoilAlbedo(bounds, & num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - albsnd(bounds%begc:bounds%endc, :), & + cosinc_col(bounds%begc:bounds%endc), & + albsnd(bounds%begc:bounds%endc, :), & albsni(bounds%begc:bounds%endc, :), & lakestate_vars, surfalb_vars) @@ -398,8 +397,7 @@ subroutine SurfaceAlbedo(bounds, & ! BC FORCING CALCULATIONS flg_slr = 1; ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -409,23 +407,10 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsnd_bc(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsnd_bc(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad flg_slr = 2; ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -435,18 +420,6 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsni_bc(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_bc(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsni_bc(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad ! 2. OC input array: ! set BC and dust concentrations, so OC_FRC=[(BC+OC+dust)-(BC+dust)] @@ -460,8 +433,7 @@ subroutine SurfaceAlbedo(bounds, & ! OC FORCING CALCULATIONS flg_slr = 1; ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -471,22 +443,9 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsnd_oc(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsnd_oc(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad flg_slr = 2; ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -496,18 +455,6 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsni_oc(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_oc(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsni_oc(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad endif ! 3. DUST input array: @@ -521,8 +468,7 @@ subroutine SurfaceAlbedo(bounds, & ! DUST FORCING CALCULATIONS flg_slr = 1; ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -532,22 +478,9 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsnd_dst(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsnd_dst(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad flg_slr = 2; ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -557,24 +490,11 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsni_dst(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_dst(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsni_dst(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad ! 4. ALL AEROSOL FORCING CALCULATION ! (pure snow albedo) flg_slr = 1; ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -584,22 +504,9 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsnd_pur(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_pur(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsnd_pur(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad flg_slr = 2; ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -609,25 +516,12 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsni_pur(bounds%begc:bounds%endc, :), & foo_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_frc_pur(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsni_pur(bounds%begc:bounds%endc, :), & - foo_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad end if !end if use_snicar_frc ! CLIMATE FEEDBACK CALCULATIONS, ALL AEROSOLS: flg_slr = 1; ! direct-beam - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -637,22 +531,9 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsnd(bounds%begc:bounds%endc, :), & flx_absd_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_fdb(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsnd(bounds%begc:bounds%endc, :), & - flx_absd_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad flg_slr = 2; ! diffuse - if (use_snicar_ad) then - call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & + call SNICAR_AD_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & cosinc_col(bounds%begc:bounds%endc), & flg_slr, & h2osno_liq(bounds%begc:bounds%endc, :), & @@ -662,18 +543,6 @@ subroutine SurfaceAlbedo(bounds, & albsfc(bounds%begc:bounds%endc, :), & albsni(bounds%begc:bounds%endc, :), & flx_absi_snw(bounds%begc:bounds%endc, :, :) ) - else - call SNICAR_RT(flg_snw_ice, bounds, num_nourbanc, filter_nourbanc, & - cosinc_col(bounds%begc:bounds%endc), & - flg_slr, & - h2osno_liq(bounds%begc:bounds%endc, :), & - h2osno_ice(bounds%begc:bounds%endc, :), & - snw_rds_in(bounds%begc:bounds%endc, :), & - mss_cnc_aer_in_fdb(bounds%begc:bounds%endc, :, :), & - albsfc(bounds%begc:bounds%endc, :), & - albsni(bounds%begc:bounds%endc, :), & - flx_absi_snw(bounds%begc:bounds%endc, :, :) ) - endif ! end if use_snicar_ad ! ground albedos and snow-fraction weighting of snow absorption factors do ib = 1, nband @@ -962,11 +831,7 @@ subroutine SurfaceAlbedo(bounds, & ! Calculate surface albedos and fluxes ! Only perform on vegetated pfts where coszen > 0 if(use_fates)then -#ifndef _OPENACC - call alm_fates%wrap_canopy_radiation(bounds,surfalb_vars,nextsw_cday,declinp1) - -#endif else if (use_top_solar_rad) then diff --git a/components/elm/src/biogeophys/SurfaceAlbedoType.F90 b/components/elm/src/biogeophys/SurfaceAlbedoType.F90 index 3a2065d07f65..825db662fcf3 100644 --- a/components/elm/src/biogeophys/SurfaceAlbedoType.F90 +++ b/components/elm/src/biogeophys/SurfaceAlbedoType.F90 @@ -25,16 +25,14 @@ module SurfaceAlbedoType ! albedo land ice by waveband (1=vis, 2=nir) real(r8), public :: albice(numrad) = (/ 0.80_r8, 0.55_r8 /) - !$acc declare copyin(albice) ! namelist default setting for inputting alblakwi real(r8), public :: lake_melt_icealb(numrad) = (/ 0.10_r8, 0.10_r8/) - !$acc declare copyin(lake_melt_icealb) ! albedo frozen lakes by waveband (1=vis, 2=nir) ! unclear what the reference is for this real(r8), public :: alblak(numrad) = (/0.60_r8, 0.40_r8/) - !$acc declare copyin(alblak) + !$acc declare create(albice, lake_melt_icealb, alblak) ! albedo of melting lakes due to puddling, open water, or white ice ! From D. Mironov (2010) Boreal Env. Research @@ -140,6 +138,7 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) use spmdMod , only : masterproc use topounit_varcon, only : max_topounits use GridcellType , only : grc_pp + use shr_sys_mod , only : shr_sys_flush ! ! !ARGUMENTS: type(bounds_type), intent(in) :: bounds @@ -151,7 +150,7 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) character(len=256) :: locfn ! local filename integer :: ier ! error status logical :: readvar - integer ,pointer :: soic2d (:,:) ! read in - soil color + integer ,pointer :: soic2d (:) ! read in - soil color !--------------------------------------------------------------------- ! Allocate module variable for soil color @@ -160,14 +159,19 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) ! Determine soil color and number of soil color classes ! if number of soil color classes is not on input dataset set it to 8 - + write(iulog, *) "DEBUG: SurfAlb::getfil", fsurdat + call shr_sys_flush(iulog) call getfil (fsurdat, locfn, 0) + write(iulog, *) "DEBUG: SurfAlb::getfil", locfn + call shr_sys_flush(iulog) call ncd_pio_openfile (ncid, locfn, 0) - call ncd_io(ncid=ncid, varname='mxsoil_color', flag='read', data=mxsoil_color, readvar=readvar) - if ( .not. readvar ) mxsoil_color = 8 + !call ncd_io(ncid=ncid, varname='mxsoil_color', flag='read', data=mxsoil_color, readvar=readvar) + !if ( .not. readvar ) mxsoil_color = 8 + mxsoil_color = 20 - allocate(soic2d(bounds%begg:bounds%endg,max_topounits)) + !allocate(soic2d(bounds%begg:bounds%endg,max_topounits)) + allocate(soic2d(bounds%begg:bounds%endg) ) call ncd_io(ncid=ncid, varname='SOIL_COLOR', flag='read', data=soic2d, dim1name=grlnd, readvar=readvar) if (.not. readvar) then call endrun(msg=' ERROR: SOIL_COLOR NOT on surfdata file'//errMsg(__FILE__, __LINE__)) @@ -177,12 +181,15 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) t = col_pp%topounit(c) topi = grc_pp%topi(g) ti = t - topi + 1 - isoicol(c) = soic2d(g,ti) + !isoicol(c) = soic2d(g,ti) + isoicol(c) = soic2d(g) end do deallocate(soic2d) call ncd_pio_closefile(ncid) + write(iulog, *) "DEBUG: SurfAlb::albsat" + call shr_sys_flush(iulog) ! Determine saturated and dry soil albedos for n color classes and ! numrad wavebands (1=vis, 2=nir) @@ -196,6 +203,8 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) if (masterproc) then write(iulog,*) 'Attempting to read soil colo data .....' end if + write(iulog, *) "DEBUG: SurfAlb::Assinments" + call shr_sys_flush(iulog) if (mxsoil_color == 8) then albsat(1:8,1) = (/0.12_r8,0.11_r8,0.10_r8,0.09_r8,0.08_r8,0.07_r8,0.06_r8,0.05_r8/) @@ -219,7 +228,8 @@ subroutine SurfaceAlbedoInitTimeConst(bounds) ! Set alblakwi alblakwi(:) = lake_melt_icealb(:) - !$acc enter data copyin(albsat,albdry,isoicol,alblakwi ) + !$acc update device(albsat,albdry,isoicol,alblakwi ) + call shr_sys_flush(iulog) end subroutine SurfaceAlbedoInitTimeConst !------------------------------------------------------------------------ diff --git a/components/elm/src/biogeophys/SurfaceRadiationMod.F90 b/components/elm/src/biogeophys/SurfaceRadiationMod.F90 index 1b041243595c..62cdb1f75c97 100644 --- a/components/elm/src/biogeophys/SurfaceRadiationMod.F90 +++ b/components/elm/src/biogeophys/SurfaceRadiationMod.F90 @@ -11,7 +11,6 @@ module SurfaceRadiationMod use abortutils , only : endrun use decompMod , only : bounds_type use elm_varcon , only : namec, spval, ispval - use atm2lndType , only : atm2lnd_type use CanopyStateType , only : canopystate_type use SurfaceAlbedoType , only : surfalb_type use SolarAbsorbedType , only : solarabs_type @@ -296,15 +295,13 @@ subroutine InitCold(this, bounds) ! !LOCAL VARIABLES: integer :: p,l !----------------------------------------------------------------------- - - ! nothing for now - + end subroutine InitCold !------------------------------------------------------------------------------ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & num_urbanp, filter_urbanp, num_urbanc, filter_urbanc, & - atm2lnd_vars, canopystate_vars, surfalb_vars, & + canopystate_vars, surfalb_vars, & solarabs_vars, surfrad_vars) ! ! !DESCRIPTION: @@ -324,7 +321,6 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & ! Output variables are parsun,parsha,sabv,sabg,fsa,fsr,ndvi ! ! !USES: - !$acc routine seq use elm_varpar , only : numrad, nlevsno use elm_varcon , only : spval, degpsec, isecspday use landunit_varcon , only : istsoil, istcrop @@ -339,13 +335,10 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & integer , intent(in) :: filter_urbanp(:) ! patch filter for non-urban points integer , intent(in) :: num_urbanc ! number of urban columns in clump integer , intent(in) :: filter_urbanc(:) ! urban column filter - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(surfalb_type) , intent(in) :: surfalb_vars type(canopystate_type) , intent(inout) :: canopystate_vars type(solarabs_type) , intent(inout) :: solarabs_vars type(surfrad_type) , intent(inout) :: surfrad_vars - real(r8) :: dtime - integer :: secs ! ! !LOCAL VARIABLES: integer , parameter :: nband = numrad ! number of solar radiation waveband classes @@ -362,10 +355,10 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & integer :: i ! layer index [idx] real(r8) :: rnir ! reflected solar radiation [nir] (W/m**2) real(r8) :: rvis ! reflected solar radiation [vis] (W/m**2) - real(r8) :: trd(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: direct (W/m**2) - real(r8) :: tri(bounds%begp:bounds%endp,numrad) ! transmitted solar radiation: diffuse (W/m**2) - real(r8) :: cad(bounds%begp:bounds%endp,numrad) ! direct beam absorbed by canopy (W/m**2) - real(r8) :: cai(bounds%begp:bounds%endp,numrad) ! diffuse radiation absorbed by canopy (W/m**2) + real(r8) :: trd(1:num_nourbanp,numrad) ! transmitted solar radiation: direct (W/m**2) + real(r8) :: tri(1:num_nourbanp,numrad) ! transmitted solar radiation: diffuse (W/m**2) + real(r8) :: cad !(1:num_nourbanp,numrad) ! direct beam absorbed by canopy (W/m**2) + real(r8) :: cai !(1:num_nourbanp,numrad) ! diffuse radiation absorbed by canopy (W/m**2) integer :: local_secp1 ! seconds into current date in local time integer :: year,month,day ! calendar info for current time step real(r8) :: sabg_snl_sum ! temporary, absorbed energy in all active snow layers [W/m2] @@ -373,13 +366,14 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & real(r8) :: absrad_bc ! temp: absorbed solar radiation without BC [W/m2] real(r8) :: absrad_oc ! temp: absorbed solar radiation without OC [W/m2] real(r8) :: absrad_dst ! temp: absorbed solar radiation without dust [W/m2] - real(r8) :: sabg_pur(bounds%begp:bounds%endp) ! solar radiation absorbed by ground with pure snow [W/m2] - real(r8) :: sabg_bc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without BC [W/m2] - real(r8) :: sabg_oc(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without OC [W/m2] - real(r8) :: sabg_dst(bounds%begp:bounds%endp) ! solar radiation absorbed by ground without dust [W/m2] - real(r8) :: parveg(bounds%begp:bounds%endp) ! absorbed par by vegetation (W/m**2) + real(r8) :: sabg_pur(1:num_nourbanp) ! solar radiation absorbed by ground with pure snow [W/m2] + real(r8) :: sabg_bc(1:num_nourbanp) ! solar radiation absorbed by ground without BC [W/m2] + real(r8) :: sabg_oc(1:num_nourbanp) ! solar radiation absorbed by ground without OC [W/m2] + real(r8) :: sabg_dst(1:num_nourbanp) ! solar radiation absorbed by ground without dust [W/m2] + real(r8) :: parveg(1:num_nourbanp) ! absorbed par by vegetation (W/m**2) ! integer, parameter :: noonsec = isecspday / 2 ! seconds at local noon + real(r8) :: sum1 ,sum2, sum3, sum4, sum5 ! !------------------------------------------------------------------------------ @@ -474,9 +468,23 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & fsds_sno_vi => surfrad_vars%fsds_sno_vi_patch , & ! Output: [real(r8) (:) ] incident visible, diffuse radiation on snow (for history files) (pft) [W/m2] fsds_sno_ni => surfrad_vars%fsds_sno_ni_patch & ! Output: [real(r8) (:) ] incident near-IR, diffuse radiation on snow (for history files) (pft) [W/m2] ) + + !$acc enter data create(& + !$acc trd(:,:), & + !$acc tri(:,:), & + !$acc sabg_pur(:), & + !$acc sabg_bc(:), & + !$acc sabg_oc(:), & + !$acc sabg_dst(:), & + !$acc parveg(:), & + !$acc ib, & + !$acc local_secp1, & + !$acc sabg_snl_sum, & + !$acc sum1, & + !$acc sum2, & + !$acc sum3, & + !$acc sum4) - dtime = dtime_mod - secs = secs_curr if (.not. use_finetop_rad) then forc_solad_pp(:,:) = forc_solad(:,:) @@ -484,184 +492,223 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & end if ! Initialize fluxes + !$acc parallel loop independent gang vector default(present) do fp = 1,num_nourbanp p = filter_nourbanp(fp) - l = veg_pp%landunit(p) - sabg_soil(p) = 0._r8 - sabg_snow(p) = 0._r8 - sabg(p) = 0._r8 - sabv(p) = 0._r8 - fsa(p) = 0._r8 - if (veg_pp%is_on_soil_col(p) .or. veg_pp%is_on_crop_col(p)) then - fsa_r(p) = 0._r8 - end if sabg_lyr(p,:) = 0._r8 - sabg_pur(p) = 0._r8 - sabg_bc(p) = 0._r8 - sabg_oc(p) = 0._r8 - sabg_dst(p) = 0._r8 - end do ! zero-out fsun for the urban patches ! the non-urban patches were set prior to this call ! and split into ed and non-ed specific functions + !$acc parallel loop independent gang vector default(present) do fp = 1,num_urbanp p = filter_urbanp(fp) fsun(p) = 0._r8 end do ! Loop over nband wavebands - do ib = 1, nband - do fp = 1,num_nourbanp - p = filter_nourbanp(fp) - c = veg_pp%column(p) - l = veg_pp%landunit(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) - - ! Absorbed by canopy - - cad(p,ib) = forc_solad(t,ib)*fabd(p,ib) - cai(p,ib) = forc_solai(t,ib)*fabi(p,ib) - sabv(p) = sabv(p) + cad(p,ib) + cai(p,ib) - fsa(p) = fsa(p) + cad(p,ib) + cai(p,ib) + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3) + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + l = veg_pp%landunit(p) + t = veg_pp%topounit(p) + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2,sum3) + do ib = 1, nband + ! Absorbed by canopys + cad = forc_solad(t,ib)*fabd(p,ib) + cai = forc_solai(t,ib)*fabi(p,ib) + sum1 = sum1 + cad + cai + sum2 = sum2 + cad + cai if (ib == 1) then - parveg(p) = cad(p,ib) + cai(p,ib) + parveg(fp) = cad + cai end if if (veg_pp%is_on_soil_col(p) .or. veg_pp%is_on_crop_col(p)) then - fsa_r(p) = fsa_r(p) + cad(p,ib) + cai(p,ib) + sum3 = sum3 + cad + cai end if - + end do + sabv(p) = sum1 + fsa(p) = sum2 + if (lun_pp%itype(l)==istsoil .or. lun_pp%itype(l)==istcrop) then + fsa_r(p)= sum3 + end if + end do ! + + !$acc parallel loop independent gang vector collapse(2) default(present) + do ib = 1, nband + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + t = veg_pp%topounit(p) ! Transmitted = solar fluxes incident on ground - - trd(p,ib) = forc_solad(t,ib)*ftdd(p,ib) - tri(p,ib) = forc_solad(t,ib)*ftid(p,ib) + forc_solai(t,ib)*ftii(p,ib) + trd(fp,ib) = forc_solad(t,ib)*ftdd(p,ib) + tri(fp,ib) = forc_solad(t,ib)*ftid(p,ib) + forc_solai(t,ib)*ftii(p,ib) + end do + end do + + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3, sum4) + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + t = veg_pp%topounit(p) + c = veg_pp%column(p) + l = veg_pp%landunit(p) + + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8; sum4 = 0._r8; + + !$acc loop vector reduction(+:sum1,sum2,sum3,sum4) private(absrad) + do ib = 1, nband ! Solar radiation absorbed by ground surface ! calculate absorbed solar by soil/snow separately - absrad = trd(p,ib)*(1._r8-albsod(c,ib)) + tri(p,ib)*(1._r8-albsoi(c,ib)) - sabg_soil(p) = sabg_soil(p) + absrad - absrad = trd(p,ib)*(1._r8-albsnd_hst(c,ib)) + tri(p,ib)*(1._r8-albsni_hst(c,ib)) - sabg_snow(p) = sabg_snow(p) + absrad - absrad = trd(p,ib)*(1._r8-albgrd(c,ib)) + tri(p,ib)*(1._r8-albgri(c,ib)) - sabg(p) = sabg(p) + absrad - fsa(p) = fsa(p) + absrad - if (veg_pp%is_on_soil_col(p) .or. veg_pp%is_on_crop_col(p)) then - fsa_r(p) = fsa_r(p) + absrad - end if - if (snl(c) == 0) then - sabg_snow(p) = sabg(p) - sabg_soil(p) = sabg(p) - endif - ! if no subgrid fluxes, make sure to set both components equal to weighted average - if (subgridflag == 0 .or. lun_pp%itype(l) == istdlak) then - sabg_snow(p) = sabg(p) - sabg_soil(p) = sabg(p) - endif + absrad = trd(fp,ib)*(1._r8-albsod(c,ib)) + tri(fp,ib)*(1._r8-albsoi(c,ib)) + sum1 = sum1 + absrad - if (use_snicar_frc) then + absrad = trd(fp,ib)*(1._r8-albsnd_hst(c,ib)) + tri(fp,ib)*(1._r8-albsni_hst(c,ib)) + sum2 = sum2 + absrad + + absrad = trd(fp,ib)*(1._r8-albgrd(c,ib)) + tri(fp,ib)*(1._r8-albgri(c,ib)) + sum3 = sum3 + absrad + if (veg_pp%is_on_soil_col(p) .or. veg_pp%is_on_crop_col(p)) then + sum4 = sum4 + absrad + end if + end do + sabg_soil(p) = sum1 + sabg_snow(p) = sum2 + sabg(p) = sum3 + fsa(p) = fsa(p) + sum3 + fsa_r(p) = fsa_r(p) + sum4 + + !NOTE: check sooner to save on the reduction? + if (snl(c) == 0) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + ! if no subgrid fluxes, make sure to set both components equal to weighted average + if (subgridflag == 0 .or. lun_pp%itype(l) == istdlak) then + sabg_snow(p) = sabg(p) + sabg_soil(p) = sabg(p) + endif + end do + + if (use_snicar_frc) then + !$acc parallel loop independent gang worker default(present) private(sum1,sum2,sum3,sum4) + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = veg_pp%column(p) + + sum1 = 0._r8; sum2 = 0._r8; sum3 = 0._r8; sum4 = 0._r8; + !$acc loop vector reduction(+:sum1,sum2,sum3,sum4) private(absrad) + do ib = 1, nband ! Solar radiation absorbed by ground surface without BC - absrad_bc = trd(p,ib)*(1._r8-albgrd_bc(c,ib)) + tri(p,ib)*(1._r8-albgri_bc(c,ib)) - sabg_bc(p) = sabg_bc(p) + absrad_bc + absrad_bc = trd(fp,ib)*(1._r8-albgrd_bc(c,ib)) + tri(fp,ib)*(1._r8-albgri_bc(c,ib)) + sum1 = sum1 + absrad_bc ! Solar radiation absorbed by ground surface without OC - absrad_oc = trd(p,ib)*(1._r8-albgrd_oc(c,ib)) + tri(p,ib)*(1._r8-albgri_oc(c,ib)) - sabg_oc(p) = sabg_oc(p) + absrad_oc + absrad_oc = trd(fp,ib)*(1._r8-albgrd_oc(c,ib)) + tri(fp,ib)*(1._r8-albgri_oc(c,ib)) + sum2 = sum2 + absrad_oc ! Solar radiation absorbed by ground surface without dust - absrad_dst = trd(p,ib)*(1._r8-albgrd_dst(c,ib)) + tri(p,ib)*(1._r8-albgri_dst(c,ib)) - sabg_dst(p) = sabg_dst(p) + absrad_dst + absrad_dst = trd(fp,ib)*(1._r8-albgrd_dst(c,ib)) + tri(fp,ib)*(1._r8-albgri_dst(c,ib)) + sum3 = sum3 + absrad_dst ! Solar radiation absorbed by ground surface without any aerosols - absrad_pur = trd(p,ib)*(1._r8-albgrd_pur(c,ib)) + tri(p,ib)*(1._r8-albgri_pur(c,ib)) - sabg_pur(p) = sabg_pur(p) + absrad_pur - end if + absrad_pur = trd(fp,ib)*(1._r8-albgrd_pur(c,ib)) + tri(fp,ib)*(1._r8-albgri_pur(c,ib)) + sum4 = sum4 + absrad_pur + end do + sabg_bc(fp) = sum1 + sabg_oc(fp) = sum2 + sabg_dst(fp) = sum3 + sabg_pur(fp) = sum4 - end do ! end of pft loop - end do ! end nbands loop + end do + end if ! compute absorbed flux in each snow layer and top soil layer, ! based on flux factors computed in the radiative transfer portion of SNICAR. - do fp = 1,num_nourbanp - p = filter_nourbanp(fp) - c = veg_pp%column(p) - l = veg_pp%landunit(p) - sabg_snl_sum = 0._r8 - - sub_surf_abs_SW(c) = 0._r8 - - ! CASE1: No snow layers: all energy is absorbed in top soil layer - if (snl(c) == 0) then - sabg_lyr(p,:) = 0._r8 - sabg_lyr(p,1) = sabg(p) - sabg_snl_sum = sabg_lyr(p,1) - - ! CASE 2: Snow layers present: absorbed radiation is scaled according to - ! flux factors computed by SNICAR - else - do i = -nlevsno+1,1,1 - sabg_lyr(p,i) = flx_absdv(c,i)*trd(p,1) + flx_absdn(c,i)*trd(p,2) + & - flx_absiv(c,i)*tri(p,1) + flx_absin(c,i)*tri(p,2) - ! summed radiation in active snow layers: - if (i >= snl(c)+1) then - sabg_snl_sum = sabg_snl_sum + sabg_lyr(p,i) - endif - if (i > snl(c)+1) then ! if snow layer is below surface snow layer - !accumulate subsurface flux as a diagnostic for history file - sub_surf_abs_SW(c) = sub_surf_abs_SW(c) + sabg_lyr(p,i) - endif - enddo - - ! Divide absorbed by total, to get % absorbed in subsurface - if (sabg_snl_sum /= 0._r8) then - sub_surf_abs_SW(c) = sub_surf_abs_SW(c)/sabg_snl_sum - else - sub_surf_abs_SW(c) = 0._r8 - endif - - ! Error handling: The situation below can occur when solar radiation is - ! NOT computed every timestep. - ! When the number of snow layers has changed in between computations of the - ! absorbed solar energy in each layer, we must redistribute the absorbed energy - ! to avoid physically unrealistic conditions. The assumptions made below are - ! somewhat arbitrary, but this situation does not arise very frequently. - ! This error handling is implemented to accomodate any value of the - ! radiation frequency. - ! change condition to match sabg_snow isntead of sabg - if (abs(sabg_snl_sum-sabg_snow(p)) > 0.00001_r8) then - if (snl(c) == 0) then - sabg_lyr(p,-nlevsno+1:0) = 0._r8 - sabg_lyr(p,1) = sabg(p) - elseif (snl(c) == -1) then - sabg_lyr(p,-nlevsno+1:-1) = 0._r8 - sabg_lyr(p,0) = sabg_snow(p)*0.6_r8 - sabg_lyr(p,1) = sabg_snow(p)*0.4_r8 - else - sabg_lyr(p,:) = 0._r8 - sabg_lyr(p,snl(c)+1) = sabg_snow(p)*0.75_r8 - sabg_lyr(p,snl(c)+2) = sabg_snow(p)*0.25_r8 - endif - endif - - ! If shallow snow depth, all solar radiation absorbed in top or top two snow layers - ! to prevent unrealistic timestep soil warming - if (subgridflag == 0 .or. col_pp%is_lake(c)) then - if (snow_depth(c) < 0.10_r8) then - if (snl(c) == 0) then - sabg_lyr(p,-nlevsno+1:0) = 0._r8 - sabg_lyr(p,1) = sabg(p) - elseif (snl(c) == -1) then - sabg_lyr(p,-nlevsno+1:-1) = 0._r8 - sabg_lyr(p,0) = sabg(p) - sabg_lyr(p,1) = 0._r8 - else - sabg_lyr(p,:) = 0._r8 - sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8 - sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8 - endif - endif - endif - endif + !$acc parallel loop independent gang worker default(present) private(sabg_snl_sum,sum1) + do fp = 1,num_nourbanp + p = filter_nourbanp(fp) + c = veg_pp%column(p) + l = veg_pp%landunit(p) + ! + sabg_snl_sum = 0._r8 + sum1 = 0._r8 + !sub_surf_abs_SW(c) = 0._r8 + + ! CASE1: No snow layers: all energy is absorbed in top soil layer + if (snl(c) == 0) then + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,1) = sabg(p) + sabg_snl_sum = sabg_lyr(p,1) + ! CASE 2: Snow layers present: absorbed radiation is scaled according to + ! flux factors computed by SNICAR + sub_surf_abs_SW(c) = 0._r8 + else + !$acc loop vector reduction(+:sabg_snl_sum,sum1) + do i = -nlevsno+1,1,1 + sabg_lyr(p,i) = flx_absdv(c,i)*trd(fp,1) + flx_absdn(c,i)*trd(fp,2) + & + flx_absiv(c,i)*tri(fp,1) + flx_absin(c,i)*tri(fp,2) + ! summed radiation in active snow layers: + if (i >= snl(c)+1) then + sabg_snl_sum = sabg_snl_sum + sabg_lyr(p,i) + endif + if (i > snl(c)+1) then ! if snow layer is below surface snow layer + !accumulate subsurface flux as a diagnostic for history file + sum1 = sum1 + sabg_lyr(p,i) + endif + enddo + sub_surf_abs_SW(c) = sum1 + + ! Divide absorbed by total, to get % absorbed in subsurface + if (sabg_snl_sum /= 0._r8) then + sub_surf_abs_SW(c) = sub_surf_abs_SW(c)/sabg_snl_sum + else + sub_surf_abs_SW(c) = 0._r8 + endif + + ! Error handling: The situation below can occur when solar radiation is + ! NOT computed every timestep. + ! When the number of snow layers has changed in between computations of the + ! absorbed solar energy in each layer, we must redistribute the absorbed energy + ! to avoid physically unrealistic conditions. The assumptions made below are + ! somewhat arbitrary, but this situation does not arise very frequently. + ! This error handling is implemented to accomodate any value of the + ! radiation frequency. + ! change condition to match sabg_snow isntead of sabg + if (abs(sabg_snl_sum-sabg_snow(p)) > 0.00001_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg_snow(p)*0.6_r8 + sabg_lyr(p,1) = sabg_snow(p)*0.4_r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg_snow(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg_snow(p)*0.25_r8 + endif + endif + + ! If shallow snow depth, all solar radiation absorbed in top or top two snow layers + ! to prevent unrealistic timestep soil warming + if (subgridflag == 0 .or. lun_pp%itype(l) == istdlak) then + if (snow_depth(c) < 0.10_r8) then + if (snl(c) == 0) then + sabg_lyr(p,-nlevsno+1:0) = 0._r8 + sabg_lyr(p,1) = sabg(p) + elseif (snl(c) == -1) then + sabg_lyr(p,-nlevsno+1:-1) = 0._r8 + sabg_lyr(p,0) = sabg(p) + sabg_lyr(p,1) = 0._r8 + else + sabg_lyr(p,:) = 0._r8 + sabg_lyr(p,snl(c)+1) = sabg(p)*0.75_r8 + sabg_lyr(p,snl(c)+2) = sabg(p)*0.25_r8 + endif + endif + endif + + endif ! This situation should not happen: if (abs(sum(sabg_lyr(p,:))-sabg_snow(p)) > 0.00001_r8) then @@ -691,22 +738,21 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & end if if (use_snicar_frc) then - ! BC aerosol forcing (pft-level): - sfc_frc_bc(p) = sabg(p) - sabg_bc(p) + sfc_frc_bc(p) = sabg(p) - sabg_bc(fp) ! OC aerosol forcing (pft-level): if (DO_SNO_OC) then - sfc_frc_oc(p) = sabg(p) - sabg_oc(p) + sfc_frc_oc(p) = sabg(p) - sabg_oc(fp) else sfc_frc_oc(p) = 0._r8 endif ! dust aerosol forcing (pft-level): - sfc_frc_dst(p) = sabg(p) - sabg_dst(p) + sfc_frc_dst(p) = sabg(p) - sabg_dst(fp) ! all-aerosol forcing (pft-level): - sfc_frc_aer(p) = sabg(p) - sabg_pur(p) + sfc_frc_aer(p) = sabg(p) - sabg_pur(fp) ! forcings averaged only over snow: if (frac_sno(c) > 0._r8) then @@ -721,9 +767,10 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & sfc_frc_aer_sno(p) = spval endif end if - enddo + enddo ! Radiation diagnostics + !$acc parallel loop independent gang vector default(present) do fp = 1,num_nourbanp p = filter_nourbanp(fp) t = veg_pp%topounit(p) @@ -747,7 +794,7 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & solarabs_vars%fsr_vis_d_patch(p) = fsr_vis_d(p) solarabs_vars%fsr_vis_i_patch(p) = fsr_vis_i(p) - local_secp1 = secs + nint((grc_pp%londeg(g)/degpsec)/dtime)*dtime + local_secp1 = secs_curr + nint((grc_pp%londeg(g)/degpsec)/dtime_mod)*dtime_mod local_secp1 = mod(local_secp1,isecspday) if (local_secp1 == isecspday/2) then fsds_vis_d_ln(p) = forc_solad(t,1) @@ -755,7 +802,7 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & fsr_vis_d_ln(p) = albd(p,1)*forc_solad(t,1) fsr_nir_d_ln(p) = albd(p,2)*forc_solad(t,2) fsds_vis_i_ln(p) = forc_solai(t,1) - parveg_ln(p) = parveg(p) + parveg_ln(p) = parveg(fp) else fsds_vis_d_ln(p) = spval fsds_nir_d_ln(p) = spval @@ -790,12 +837,14 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & fsr_sno_ni(p) = spval endif end do + + !$acc parallel loop independent gang vector default(present) do fp = 1,num_urbanp p = filter_urbanp(fp) t = veg_pp%topounit(p) g = veg_pp%gridcell(p) - local_secp1 = secs + nint((grc_pp%londeg(g)/degpsec)/dtime)*dtime + local_secp1 = secs_curr + nint((grc_pp%londeg(g)/degpsec)/dtime_mod)*dtime_mod local_secp1 = mod(local_secp1,isecspday) if(elai(p)==0.0_r8.and.fabd(p,1)>0._r8)then @@ -845,6 +894,22 @@ subroutine SurfaceRadiation(bounds, num_nourbanp, filter_nourbanp, & fsr(p) = fsr_vis_d(p) + fsr_nir_d(p) + fsr_vis_i(p) + fsr_nir_i(p) end do + !$acc exit data delete(& + !$acc trd(:,:), & + !$acc tri(:,:), & + !$acc sabg_pur(:), & + !$acc sabg_bc(:), & + !$acc sabg_oc(:), & + !$acc sabg_dst(:), & + !$acc parveg(:), & + !$acc ib, & + !$acc local_secp1, & + !$acc sabg_snl_sum, & + !$acc sum1, & + !$acc sum2, & + !$acc sum3, & + !$acc sum4) + end associate end subroutine SurfaceRadiation @@ -852,7 +917,7 @@ end subroutine SurfaceRadiation !------------------------------------------------------------------------------ subroutine CanopySunShadeFractions(num_nourbanp, filter_nourbanp, & - atm2lnd_vars, surfalb_vars, & + surfalb_vars, & canopystate_vars, solarabs_vars) ! ------------------------------------------------------------------------------------ @@ -873,14 +938,11 @@ subroutine CanopySunShadeFractions(num_nourbanp, filter_nourbanp, & ! variables also needs to be augmented in that routine as well. ! ------------------------------------------------------------------------------------ - !$acc routine seq implicit none ! Arguments (in) - integer, intent(in) :: num_nourbanp ! size of the nonurban filter integer, intent(in) :: filter_nourbanp(:) ! patch filter for non-urban points - type(atm2lnd_type), intent(in) :: atm2lnd_vars type(surfalb_type), intent(in) :: surfalb_vars ! Arguments (inout) @@ -894,6 +956,7 @@ subroutine CanopySunShadeFractions(num_nourbanp, filter_nourbanp, & integer :: g ! gridcell index integer :: iv ! canopy layer index integer,parameter :: ipar = 1 ! The band index for PAR + real(r8) :: sum1, sum2 associate( & tlai_z => surfalb_vars%tlai_z_patch, & ! tlai increment for canopy layer @@ -912,33 +975,30 @@ subroutine CanopySunShadeFractions(num_nourbanp, filter_nourbanp, & laisha => canopystate_vars%laisha_patch, & ! shaded leaf area laisun_z => canopystate_vars%laisun_z_patch, & ! sunlit leaf area for canopy layer laisha_z => canopystate_vars%laisha_z_patch, & ! shaded leaf area for canopy layer - fsun => canopystate_vars%fsun_patch) ! sunlit fraction of canopy + fsun => canopystate_vars%fsun_patch ) ! sunlit fraction of canopy - do fp = 1,num_nourbanp + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) + do fp = 1,num_nourbanp p = filter_nourbanp(fp) t = veg_pp%topounit(p) - do iv = 1, nrad(p) - parsun_z(p,iv) = 0._r8 - parsha_z(p,iv) = 0._r8 - laisun_z(p,iv) = 0._r8 - laisha_z(p,iv) = 0._r8 - end do - ! Loop over patches to calculate laisun_z and laisha_z for each layer. ! Derive canopy laisun, laisha, and fsun from layer sums. ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - laisun(p) = 0._r8 - laisha(p) = 0._r8 + sum1 = 0._r8 + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2) do iv = 1, nrad(p) laisun_z(p,iv) = tlai_z(p,iv) * fsun_z(p,iv) laisha_z(p,iv) = tlai_z(p,iv) * (1._r8 - fsun_z(p,iv)) - laisun(p) = laisun(p) + laisun_z(p,iv) - laisha(p) = laisha(p) + laisha_z(p,iv) + sum1 = sum1 + laisun_z(p,iv) + sum2 = sum2 + laisha_z(p,iv) end do + laisun(p) = sum1 + laisha(p) = sum2 if (elai(p) > 0._r8) then fsun(p) = laisun(p) / elai(p) else @@ -950,16 +1010,15 @@ subroutine CanopySunShadeFractions(num_nourbanp, filter_nourbanp, & ! are canopy integrated so that layer values equal big leaf values. g = veg_pp%gridcell(p) - + !$acc loop vector independent do iv = 1, nrad(p) parsun_z(p,iv) = forc_solad(t,ipar)*fabd_sun_z(p,iv) + forc_solai(t,ipar)*fabi_sun_z(p,iv) parsha_z(p,iv) = forc_solad(t,ipar)*fabd_sha_z(p,iv) + forc_solai(t,ipar)*fabi_sha_z(p,iv) end do end do ! end of fp = 1,num_nourbanp loop - end associate - return + end associate end subroutine CanopySunShadeFractions diff --git a/components/elm/src/biogeophys/SurfaceResistanceMod.F90 b/components/elm/src/biogeophys/SurfaceResistanceMod.F90 index 27b9dccd90fa..bb56dac00ced 100644 --- a/components/elm/src/biogeophys/SurfaceResistanceMod.F90 +++ b/components/elm/src/biogeophys/SurfaceResistanceMod.F90 @@ -55,7 +55,6 @@ subroutine calc_soilevap_stress(bounds, num_nolakec, filter_nolakec, & ! DESCRIPTIONS ! compute the stress factor for soil evaporation calculation ! - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 use shr_const_mod , only : SHR_CONST_PI use decompMod , only : bounds_type @@ -68,12 +67,11 @@ subroutine calc_soilevap_stress(bounds, num_nolakec, filter_nolakec, & integer , intent(in) :: num_nolakec integer , intent(in) :: filter_nolakec(:) type(soilstate_type) , intent(inout) :: soilstate_vars - - !character(len=32) :: subname = 'calc_soilevap_stress' ! subroutine name - associate( & + character(len=32) :: subname = 'calc_soilevap_stress' ! subroutine name + associate( & soilbeta => soilstate_vars%soilbeta_col & ! Output: [real(r8) (:)] factor that reduces ground evaporation ) - + !select the right method and do the calculation select case (soil_stress_method) @@ -82,9 +80,7 @@ subroutine calc_soilevap_stress(bounds, num_nolakec, filter_nolakec, & soilstate_vars, soilbeta(bounds%begc:bounds%endc)) case default -#ifndef _OPENACC call endrun('calc_soilevap_stress' //':: a soilevap stress function must be specified!') -#endif end select end associate @@ -99,7 +95,6 @@ subroutine calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & ! compute the lee-pielke beta factor to scal actual soil evaporation from potential evaporation ! ! USES - !$acc routine seq use shr_kind_mod , only : r8 => shr_kind_r8 use shr_const_mod , only : SHR_CONST_PI use decompMod , only : bounds_type @@ -119,23 +114,23 @@ subroutine calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & real(r8) , intent(inout) :: soilbeta(bounds%begc:bounds%endc) !local variables - real(r8) :: fac, fac_fc, wx !temporary variables - integer :: c, l, fc !indices - - - associate( & - watsat => soilstate_vars%watsat_col , & ! Input: [real(r8) (:,:)] volumetric soil water at saturation (porosity) - watfc => soilstate_vars%watfc_col , & ! Input: [real(r8) (:,:)] volumetric soil water at field capacity - watmin => soilstate_vars%watmin_col , & ! Input: [real(r8) (:,:)] min volumetric soil water - sucmin => soilstate_vars%sucmin_col , & ! Input: [real(r8) (:,:)] min volumetric soil water - soilp_col => col_ws%soilp , & ! Input: [real(r8) (:,:)] soil water pressure (Pa) - - h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:)] ice lens (kg/m2) - h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:)] liquid water (kg/m2) - frac_sno => col_ws%frac_sno , & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) - frac_h2osfc => col_ws%frac_h2osfc & ! Input: [real(r8) (:)] fraction of ground covered by surface water (0 to 1) - ) - + real(r8) :: fac, fac_fc, wx ! temporary variables + integer :: c, l, fc ! indices + + associate( & + watsat => soilstate_vars%watsat_col , & ! Input: [real(r8) (:,:)] volumetric soil water at saturation (porosity) + watfc => soilstate_vars%watfc_col , & ! Input: [real(r8) (:,:)] volumetric soil water at field capacity + watmin => soilstate_vars%watmin_col , & ! Input: [real(r8) (:,:)] min volumetric soil water + sucmin => soilstate_vars%sucmin_col , & ! Input: [real(r8) (:,:)] min volumetric soil water + soilp_col => col_ws%soilp , & ! Input: [real(r8) (:,:)] soil water pressure (Pa) + + h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:)] ice lens (kg/m2) + h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:)] liquid water (kg/m2) + frac_sno => col_ws%frac_sno , & ! Input: [real(r8) (:)] fraction of ground covered by snow (0 to 1) + frac_h2osfc => col_ws%frac_h2osfc & ! Input: [real(r8) (:)] fraction of ground covered by surface water (0 to 1) + ) + + !$acc parallel loop independent gang vector default(present) do fc = 1,num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -145,15 +140,15 @@ subroutine calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & wx = (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice)/col_pp%dz(c,1) fac = min(1._r8, wx/watsat(c,1)) fac = max( fac, 0.01_r8 ) - !! Lee and Pielke 1992 beta, added by K.Sakaguchi - if (wx < watfc(c,1) ) then !when water content of ths top layer is less than that at F.C. - fac_fc = min(1._r8, wx/watfc(c,1)) !eqn5.66 but divided by theta at field capacity + ! Lee and Pielke 1992 beta, added by K.Sakaguchi + if (wx < watfc(c,1) ) then ! when water content of ths top layer is less than that at F.C. + fac_fc = min(1._r8, wx/watfc(c,1)) ! eqn5.66 but divided by theta at field capacity fac_fc = max( fac_fc, 0.01_r8 ) ! modify soil beta by snow cover. soilbeta for snow surface is one soilbeta(c) = (1._r8-frac_sno(c)-frac_h2osfc(c)) & *0.25_r8*(1._r8 - cos(SHR_CONST_PI*fac_fc))**2._r8 & - + frac_sno(c)+ frac_h2osfc(c) - else !when water content of ths top layer is more than that at F.C. + + frac_sno(c) + frac_h2osfc(c) + else ! when water content of ths top layer is more than that at F.C. soilbeta(c) = 1._r8 end if if ( use_vsfm ) then @@ -171,10 +166,10 @@ subroutine calc_beta_leepielke1992(bounds, num_nolakec, filter_nolakec, & if (wx < watfc(c,1) ) then !when water content of ths top layer is less than that at F.C. if (wx >= watmin(c,1) .and. soilp_col(c,1) >= sucmin(c,1) ) then fac_fc = min(1._r8, wx/watfc(c,1)) !eqn5.66 but divided by theta at field capacity - fac_fc = max( fac_fc, 0.01_r8 ) + fac_fc = max(fac_fc, 0.01_r8) ! modify soil beta by snow cover. soilbeta for snow surface is one soilbeta(c) = (1._r8-frac_sno(c)-frac_h2osfc(c)) & - *0.25_r8*(1._r8 - cos(SHR_CONST_PI*fac_fc))**2._r8 & + *0.25_r8*(1._r8-cos(SHR_CONST_PI*fac_fc))**2._r8 & + frac_sno(c)+ frac_h2osfc(c) else soilbeta(c) = 0._r8 diff --git a/components/elm/src/biogeophys/TotalWaterAndHeatMod.F90 b/components/elm/src/biogeophys/TotalWaterAndHeatMod.F90 index 5287b74c13c6..75406ec51776 100644 --- a/components/elm/src/biogeophys/TotalWaterAndHeatMod.F90 +++ b/components/elm/src/biogeophys/TotalWaterAndHeatMod.F90 @@ -5,13 +5,13 @@ module TotalWaterAndHeatMod ! Routines for computing total column water and heat contents ! ! !USES: -#include "shr_assert.h" + #include "shr_assert.h" use shr_kind_mod , only : r8 => shr_kind_r8 use shr_log_mod , only : errMsg => shr_log_errMsg use decompMod , only : bounds_type use elm_varcon , only : cpice, cpliq, denh2o, tfrz, hfus, aquifer_water_baseline use elm_varpar , only : nlevgrnd, nlevsoi, nlevurb, nlevlak - use subgridAveMod , only : p2c + use subgridAveMod , only : p2c_1d, unity use SoilHydrologyType , only : soilhydrology_type use UrbanParamsType , only : urbanparams_type use SoilStateType , only : soilstate_type @@ -24,6 +24,7 @@ module TotalWaterAndHeatMod use ColumnDataType , only : col_es, col_ws use VegetationType , only : veg_pp use VegetationDataType , only : veg_ws + use elm_varctl , only : iulog ! ! !PUBLIC TYPES: implicit none @@ -72,7 +73,6 @@ module TotalWaterAndHeatMod ! Minimum and maximum temperatures for the water temperature used by AdjustDeltaHeatForDeltaLiq real(r8), parameter :: DeltaLiqMinTemp = tfrz ! [K] real(r8), parameter :: DeltaLiqMaxTemp = tfrz + 35._r8 ! [K] - !$acc declare copyin(heat_base_temp, DeltaLiqMinTemp,DeltaLiqMaxTemp) ! ! !PRIVATE MEMBER FUNCTIONS: private :: AccumulateLiquidWaterHeat ! For use by ComputeHeat* routines: accumulate quantities that we need to count for liquid water, for a single column @@ -95,7 +95,7 @@ subroutine ComputeWaterMassNonLake(bounds, num_nolakec, filter_nolakec, & integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points type(soilhydrology_type) , intent(in) :: soilhydrology_inst - real(r8) , intent(inout) :: water_mass( bounds%begc: ) ! computed water mass (kg m-2) + real(r8) , intent(inout) :: water_mass(bounds%begc:) ! computed water mass (kg m-2) ! ! !LOCAL VARIABLES: real(r8) :: liquid_mass(bounds%begc:bounds%endc) ! kg m-2 @@ -104,7 +104,8 @@ subroutine ComputeWaterMassNonLake(bounds, num_nolakec, filter_nolakec, & character(len=*), parameter :: subname = 'ComputeWaterMassNonLake' !----------------------------------------------------------------------- - + + !$acc enter data copyin(liquid_mass(:), ice_mass(:)) call ComputeLiqIceMassNonLake( & bounds = bounds, & @@ -113,12 +114,16 @@ subroutine ComputeWaterMassNonLake(bounds, num_nolakec, filter_nolakec, & soilhydrology_inst = soilhydrology_inst, & liquid_mass = liquid_mass(bounds%begc:bounds%endc), & ice_mass = ice_mass(bounds%begc:bounds%endc)) - + + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) water_mass(c) = liquid_mass(c) + ice_mass(c) end do + !$acc enter data copyin(liquid_mass(:), ice_mass(:)) + + end subroutine ComputeWaterMassNonLake !----------------------------------------------------------------------- @@ -143,7 +148,6 @@ subroutine ComputeWaterMassLake(bounds, num_lakec, filter_lakec, & character(len=*), parameter :: subname = 'ComputeWaterMassLake' !----------------------------------------------------------------------- - call ComputeLiqIceMassLake( & bounds = bounds, & num_lakec = num_lakec, & @@ -171,7 +175,6 @@ subroutine ComputeLiqIceMassNonLake(bounds, num_nolakec, filter_nolakec, & ! to ComputeHeatNonLake ! ! !ARGUMENTS: - !$acc routine seq type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_nolakec ! number of column non-lake points in column filter integer , intent(in) :: filter_nolakec(:) ! column filter for non-lake points @@ -182,46 +185,36 @@ subroutine ComputeLiqIceMassNonLake(bounds, num_nolakec, filter_nolakec, & ! !LOCAL VARIABLES: integer :: c, j, fc, l, p ! indices logical :: has_h2o ! whether this point potentially has water to add - real(r8) :: h2ocan_col(bounds%begc:bounds%endc) ! canopy water (mm H2O) - real(r8) :: snocan_col(bounds%begc:bounds%endc) ! canopy snow water (mm H2O) real(r8) :: liqcan ! canopy liquid water (mm H2O) character(len=*), parameter :: subname = 'ComputeLiqIceMassNonLake' + real(r8) :: sum_liq, sum_ice !----------------------------------------------------------------------- - associate( & snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers - h2osfc => col_ws%h2osfc , & ! Input: [real(r8) (:) ] surface water (mm) h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) h2ocan_patch => veg_ws%h2ocan , & ! Input: [real(r8) (:) ] canopy water (mm H2O) -! snocan_patch => waterstate_inst%snocan_patch , & ! Input: [real(r8) (:) ] canopy snow water (mm H2O) h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) h2osoi_liq => col_ws%h2osoi_liq , & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) - total_plant_stored_h2o => col_ws%total_plant_stored_h2o, & - ! Input: [real(r8) (:,:) ] plant internal stored water (mm H2O) - wa => soilhydrology_inst%wa_col & ! Input: [real(r8) (:) ] water in the unconfined aquifer (mm) + total_plant_stored_h2o => col_ws%total_plant_stored_h2o, & ! Input: [real(r8) (:,:) ] plant internal stored water (mm H2O) + wa => soilhydrology_inst%wa_col & ! Input: [real(r8) (:) ] water in the unconfined aquifer (mm) ) - + !$acc enter data create(& + !$acc sum_liq, & + !$acc sum_ice) + do fc = 1, num_nolakec c = filter_nolakec(fc) liquid_mass(c) = 0._r8 ice_mass(c) = 0._r8 - end do - - call p2c(bounds, num_nolakec, filter_nolakec, & - h2ocan_patch(bounds%begp:bounds%endp), & - h2ocan_col(bounds%begc:bounds%endc)) - - !call p2c(bounds, num_nolakec, filter_nolakec, & - ! snocan_patch(bounds%begp:bounds%endp), & - ! snocan_col(bounds%begc:bounds%endc)) - snocan_col(:) = 0._r8 + end do + !$acc parallel loop independent gang worker default(present) private(c,sum_liq,sum_ice) do fc = 1, num_nolakec c = filter_nolakec(fc) - + ! waterstate_inst%snocan_patch and waterstate_inst%liqcan_patch are only set if ! we're using snow-on-veg; otherwise they are 0. However, we can rely on ! h2ocan_patch being set in all cases, so we can always determine the liquid mass @@ -233,37 +226,47 @@ subroutine ComputeLiqIceMassNonLake(bounds, num_nolakec, filter_nolakec, & ! non-changing, and is set to 0 for a trivial solution. if (snl(c) < 0) then - ! Loop over snow layers + sum_liq = 0._r8 + sum_ice = 0._r8 + + ! Loop over snow layers + !$acc loop vector reduction(+:sum_liq,sum_ice) do j = snl(c)+1,0 - liquid_mass(c) = liquid_mass(c) + h2osoi_liq(c,j) - ice_mass(c) = ice_mass(c) + h2osoi_ice(c,j) + sum_liq = sum_liq + h2osoi_liq(c,j) + sum_ice = sum_ice + h2osoi_ice(c,j) end do + + liquid_mass(c) = sum_liq + ice_mass(c) = sum_ice else if (h2osno(c) /= 0._r8) then ! No explicit snow layers, but there may still be some ice in h2osno (there is ! no liquid water in this case) - ice_mass(c) = ice_mass(c) + h2osno(c) + ice_mass(c) = h2osno(c) end if end do ! Soil water content - do j = 1, nlevgrnd - do fc = 1, num_nolakec - c = filter_nolakec(fc) - if (col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall .or. & - col_pp%itype(c) == icol_roof .or. col_pp%itype(c) == icol_road_imperv) then - has_h2o = .false. - else - has_h2o = .true. - end if - - if (has_h2o) then - liquid_mass(c) = liquid_mass(c) + h2osoi_liq(c,j) - ice_mass(c) = ice_mass(c) + h2osoi_ice(c,j) - end if - end do + !$acc parallel loop gang worker independent default(present) private(sum_liq,sum_ice) + do fc = 1, num_nolakec + c = filter_nolakec(fc) + if (col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall .or. & + col_pp%itype(c) == icol_roof .or. col_pp%itype(c) == icol_road_imperv) then + has_h2o = .false. + else + sum_liq = 0._r8; sum_ice = 0._r8 + !$acc loop vector reduction(+:sum_liq,sum_ice) + do j = 1, nlevgrnd + !has_h2o = .true. + sum_liq = sum_liq + h2osoi_liq(c,j) + sum_ice = sum_ice + h2osoi_ice(c,j) + end do + liquid_mass(c) = liquid_mass(c) + sum_liq + ice_mass(c) = ice_mass(c) + sum_ice + end if end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) l = col_pp%landunit(c) @@ -274,26 +277,32 @@ subroutine ComputeLiqIceMassNonLake(bounds, num_nolakec, filter_nolakec, & .or. (lun_pp%urbpoi(l) .and. col_pp%itype(c) == icol_road_perv )) then liquid_mass(c) = liquid_mass(c) + wa(c) end if - l = col_pp%landunit(c) + !ice_mass(c) = ice_mass(c) + snocan_col(c) + + end do + + !$acc parallel loop gang worker independent default(present) private(sum_liq) + do fc = 1, num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) if (col_pp%is_soil(c) .or. col_pp%is_crop(c)) then ! note: soil specified at LU level + sum_liq = 0._r8 + !$acc loop vector reduction(+:sum_liq) do p = col_pp%pfti(c),col_pp%pftf(c) ! loop over patches if (veg_pp%active(p)) then - liquid_mass(c) = liquid_mass(c) + h2ocan_patch(p) * veg_pp%wtcol(p) - end if + sum_liq = sum_liq + h2ocan_patch(p) * veg_pp%wtcol(p) + end if end do + liquid_mass(c) = liquid_mass(c) + sum_liq end if - !liqcan = h2ocan_col(c) - snocan_col(c) - !liquid_mass(c) = liquid_mass(c) + liqcan + total_plant_stored_h2o(c) - ice_mass(c) = ice_mass(c) + snocan_col(c) - - if (col_pp%itype(c) == icol_roof .or. col_pp%itype(c) == icol_sunwall & - .or. col_pp%itype(c) == icol_shadewall .or. col_pp%itype(c) == icol_road_imperv) then - ! Nothing more to add in this case - else - !liquid_mass(c) = liquid_mass(c) + h2osfc(c) - end if + end do + + !$acc exit data delete(& + !$acc sum_liq, & + !$acc sum_ice) + end associate end subroutine ComputeLiqIceMassNonLake @@ -309,7 +318,6 @@ subroutine ComputeLiqIceMassLake(bounds, num_lakec, filter_lakec, & ! to ComputeHeatLake ! ! !ARGUMENTS: - !$acc routine seq type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_lakec ! number of column lake points in column filter integer , intent(in) :: filter_lakec(:) ! column filter for lake points @@ -319,59 +327,80 @@ subroutine ComputeLiqIceMassLake(bounds, num_lakec, filter_lakec, & ! ! !LOCAL VARIABLES: integer :: c, j, fc ! indices - + real(r8) :: sum1, sum2 character(len=*), parameter :: subname = 'ComputeLiqIceMassLake' !----------------------------------------------------------------------- associate( & - snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers - + snl => col_pp%snl , & ! Input: [integer (:) ] negative number of snow layers h2osno => col_ws%h2osno , & ! Input: [real(r8) (:) ] snow water (mm H2O) h2osoi_ice => col_ws%h2osoi_ice , & ! Input: [real(r8) (:,:) ] ice lens (kg/m2) h2osoi_liq => col_ws%h2osoi_liq & ! Input: [real(r8) (:,:) ] liquid water (kg/m2) ) - - do fc = 1, num_lakec - c = filter_lakec(fc) - liquid_mass(c) = 0._r8 - ice_mass(c) = 0._r8 - end do - + !$acc enter data create(sum1, sum2) + + !$acc parallel loop independent gang vector default(present) + do fc =1, num_lakec + c = filter_lakec(fc) + liquid_mass(c) = 0._r8 + ice_mass(c) = 0._r8 + end do + ! Snow water content + !$acc parallel loop gang worker independent default(present) private(sum1,sum2) do fc = 1, num_lakec c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 if (snl(c) < 0) then ! Loop over snow layers + !$acc loop vector reduction(+:sum1,sum2) do j = snl(c)+1,0 - liquid_mass(c) = liquid_mass(c) + h2osoi_liq(c,j) - ice_mass(c) = ice_mass(c) + h2osoi_ice(c,j) + sum1 = sum1 + h2osoi_liq(c,j) + sum2 = sum2 + h2osoi_ice(c,j) end do else if (h2osno(c) /= 0._r8) then ! No explicit snow layers, but there may still be some ice in h2osno (there is ! no liquid water in this case) - ice_mass(c) = ice_mass(c) + h2osno(c) + ice_mass(c) = h2osno(c) end if + liquid_mass(c) = sum1 + ice_mass(c) = sum2 end do ! Soil water content of the soil under the lake - do j = 1, nlevgrnd - do fc = 1, num_lakec - c = filter_lakec(fc) - liquid_mass(c) = liquid_mass(c) + h2osoi_liq(c,j) - ice_mass(c) = ice_mass(c) + h2osoi_ice(c,j) + !$acc parallel loop independent gang worker default(present) private(sum1, sum2) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2) + do j = 1, nlevgrnd + sum1 = sum1 + h2osoi_liq(c,j) + sum2 = sum2 + h2osoi_ice(c,j) end do + liquid_mass(c) = liquid_mass(c) + sum1 + ice_mass(c) = ice_mass(c) + sum2 end do + !$acc parallel loop independent gang worker default(present) private(sum1,sum2) do fc = 1, num_lakec c = filter_lakec(fc) + sum1 = 0._r8 + sum2 = 0._r8 + !$acc loop vector reduction(+:sum1,sum2) do j = 1,nlevlak - liquid_mass(c) = liquid_mass(c) + (1 - lakestate_vars%lake_icefrac_col(c,j)) * col_pp%dz_lake(c,j) * denh2o - ice_mass(c) = ice_mass(c) + lakestate_vars%lake_icefrac_col(c,j) * col_pp%dz_lake(c,j) * denh2o + sum1 = sum1 + (1 - lakestate_vars%lake_icefrac_col(c,j)) * col_pp%dz_lake(c,j) * denh2o + sum2 = sum2 + lakestate_vars%lake_icefrac_col(c,j) * col_pp%dz_lake(c,j) * denh2o ! lake layers do not change thickness when freezing, so denh2o should be used ! (thermal properties are appropriately adjusted; see LakeTemperatureMod) end do + liquid_mass(c) = liquid_mass(c) + sum1 + ice_mass(c) = ice_mass(c) + sum2 end do + !$acc exit data delete(sum1, sum2) + end associate end subroutine ComputeLiqIceMassLake @@ -393,7 +422,7 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & ! generally be accompanied by similar changes to ComputeLiqIceMassNonLake ! ! !ARGUMENTS: - !$acc routine seq + type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_nolakec integer , intent(in) :: filter_nolakec(:) @@ -412,16 +441,15 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & logical :: has_h2o ! whether this point potentially has water to add real(r8) :: h2ocan_col(bounds%begc:bounds%endc) ! canopy water (mm H2O) - real(r8) :: snocan_col(bounds%begc:bounds%endc) ! canopy snow water (mm H2O) real(r8) :: liqcan ! canopy liquid water (mm H2O) - real(r8) :: heat_dry_mass(bounds%begc:bounds%endc) ! sum of heat content: dry mass [J/m^2] - real(r8) :: heat_ice(bounds%begc:bounds%endc) ! sum of heat content: ice [J/m^2] - real(r8) :: latent_heat_liquid(bounds%begc:bounds%endc) ! sum of latent heat content of liquid water [J/m^2] - - !character(len=*), parameter :: subname = 'ComputeHeatNonLake' + real(r8) :: heat_dry_mass(num_nolakec) ! sum of heat content: dry mass [J/m^2] + real(r8) :: heat_ice(num_nolakec) ! sum of heat content: ice [J/m^2] + real(r8) :: latent_heat_liquid(num_nolakec) ! sum of latent heat content of liquid water [J/m^2] + + real(r8) :: sum_heat,sum_cv,sum_latent, sum_hice, sum_dry + !----------------------------------------------------------------------- - associate( & snl => col_pp%snl, & ! number of snow layers dz => col_pp%dz, & ! layer depth (m) @@ -438,34 +466,31 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & h2osno => col_ws%h2osno, & ! snow water (mm H2O) h2osfc => col_ws%h2osfc, & ! surface water (mm H2O) h2ocan_patch => veg_ws%h2ocan, & ! canopy water (mm H2O) -! snocan_patch => waterstate_inst%snocan_patch, & ! canopy snow water (mm H2O) total_plant_stored_h2o_col => col_ws%total_plant_stored_h2o, & ! Input: [real(r8) (:) ] water mass in plant tissues (kg m-2) wa => soilhydrology_inst%wa_col & ! water in the unconfined aquifer (mm) ) + !$acc enter data create(& + !$acc h2ocan_col(:), & + !$acc heat_dry_mass(:), & + !$acc heat_ice(:), & + !$acc latent_heat_liquid(:), & + !$acc sum_hice, & + !$acc sum_dry) + + call p2c_1d(bounds, & + parr = h2ocan_patch(bounds%begp:bounds%endp), & + carr = h2ocan_col(bounds%begc:bounds%endc), & + p2c_scale_type = unity) + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) + heat_ice(fc) = 0._r8 heat_liquid(c) = 0._r8 cv_liquid(c) = 0._r8 - heat_dry_mass(c) = 0._r8 - heat_ice(c) = 0._r8 - latent_heat_liquid(c) = 0._r8 - end do - - call p2c(bounds, & - parr = h2ocan_patch(bounds%begp:bounds%endp), & - carr = h2ocan_col(bounds%begc:bounds%endc), & - p2c_scale_type = 0) - - !call p2c(bounds, & - ! parr = snocan_patch(bounds%begp:bounds%endp), & - ! carr = snocan_col(bounds%begc:bounds%endc), & - ! p2c_scale_type = 'unity') - snocan_col(bounds%begc:bounds%endc) = 0._r8 - - do fc = 1, num_nolakec - c = filter_nolakec(fc) + heat_dry_mass(fc) = 0._r8 + latent_heat_liquid(fc) = 0._r8 !--- canopy water --- ! @@ -493,35 +518,61 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & ! we are not accounting for or conserving the flux of energy between the two ! pools. The energy in the plant water should "bring with it" the internal ! energy of the soil-to-root water flux. - - liqcan = (h2ocan_col(c) - snocan_col(c) + total_plant_stored_h2o_col(c))*0._r8 + + ! NOTE: Why multiply by 0._r8? + liqcan = (h2ocan_col(c) + total_plant_stored_h2o_col(c))*0._r8 call AccumulateLiquidWaterHeat( & temp = heat_base_temp, & h2o = liqcan, & cv_liquid = cv_liquid(c), & heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) + latent_heat_liquid = latent_heat_liquid(fc)) + + end do + !$acc parallel loop independent gang worker default(present) private(sum_heat,sum_cv,sum_latent,sum_hice) + do fc = 1, num_nolakec + c = filter_nolakec(fc) !--- snow --- if ( snl(c) < 0 ) then ! Loop over snow layers + sum_heat = 0._r8 + sum_cv = 0._r8 + sum_latent = 0._r8 + sum_hice = 0._r8 + + !$acc loop vector reduction(+:sum_heat,sum_cv,sum_latent,sum_hice) do j = snl(c)+1,0 call AccumulateLiquidWaterHeat( & temp = t_soisno(c,j), & h2o = h2osoi_liq(c,j), & - cv_liquid = cv_liquid(c), & - heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) - heat_ice(c) = heat_ice(c) + & + cv_liquid = sum_cv, & + heat_liquid = sum_heat, & + latent_heat_liquid = sum_latent) + + sum_hice = sum_hice + & TempToHeat(t_soisno(c,j), (h2osoi_ice(c,j)*cpice)) end do - else if (h2osno(c) /= 0._r8) then + + cv_liquid(c) = cv_liquid(c) + sum_cv + heat_liquid(c) = heat_liquid(c) + sum_heat + latent_heat_liquid(fc) = latent_heat_liquid(fc) + sum_latent + heat_ice(fc) = sum_hice + + else if (h2osno(c) /= 0._r8) then ! No explicit snow layers, but there may still be some ice in h2osno (there is ! no liquid water in this case) - j = 1 - heat_ice(c) = heat_ice(c) + & - TempToHeat(t_soisno(c,j), (h2osno(c)*cpice)) - end if + ! j = 1 + heat_ice(fc) = heat_ice(fc) + & + TempToHeat(t_soisno(c,1), (h2osno(c)*cpice)) + end if + + end do + + + !$acc parallel loop independent gang vector default(present) + do fc = 1, num_nolakec + c = filter_nolakec(fc) if (col_pp%hydrologically_active(c)) then ! NOTE(wjs, 2017-03-23) Water in the unconfined aquifer currently doesn't have @@ -539,7 +590,7 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & h2o = (wa(c) - aquifer_water_baseline), & cv_liquid = cv_liquid(c), & heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) + latent_heat_liquid = latent_heat_liquid(fc)) end if if (col_pp%itype(c) == icol_roof .or. col_pp%itype(c) == icol_sunwall & @@ -552,30 +603,37 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & h2o = h2osfc(c), & cv_liquid = cv_liquid(c), & heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) + latent_heat_liquid = latent_heat_liquid(fc)) end if end do !--- below ground (soil & soil water) and related urban columns - do j = 1, nlevgrnd - do fc = 1, num_nolakec - c = filter_nolakec(fc) - l = col_pp%landunit(c) - - if (col_pp%itype(c) == icol_sunwall .or. col_pp%itype(c) == icol_shadewall) then + !$acc parallel loop independent gang worker default(present) private(c,l,sum_heat,sum_cv,sum_latent,sum_hice,sum_dry) & + !$acc present(heat_dry_mass(:),cv_liquid(:), heat_liquid(:), latent_heat_liquid(:), heat_ice(:) ) + do fc = 1, num_nolakec + c = filter_nolakec(fc) + l = col_pp%landunit(c) + sum_heat = 0._r8 + sum_cv = 0._r8 + sum_latent = 0._r8 + sum_hice = 0._r8 + sum_dry = 0._r8 + + !$acc loop vector reduction(+:sum_heat,sum_cv,sum_latent,sum_hice,sum_dry) private(has_h2o) + do j = 1, nlevgrnd + + if (col_pp%itype(c)==icol_sunwall .or. col_pp%itype(c)==icol_shadewall) then has_h2o = .false. if (j <= nlevurb) then - heat_dry_mass(c) = heat_dry_mass(c) + & - TempToHeat(t_soisno(c,j), (cv_wall(l,j) * dz(c,j))) + sum_dry = sum_dry + TempToHeat(t_soisno(c,j), (cv_wall(l,j) * dz(c,j)) ) end if else if (col_pp%itype(c) == icol_roof) then if (j <= nlevurb) then has_h2o = .true. - heat_dry_mass(c) = heat_dry_mass(c) + & - TempToHeat(t_soisno(c,j), (cv_roof(l,j) * dz(c,j))) + sum_dry = sum_dry + TempToHeat(t_soisno(c,j), (cv_roof(l,j) * dz(c,j))) else has_h2o = .false. end if @@ -584,12 +642,13 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & has_h2o = .true. if (col_pp%itype(c) == icol_road_imperv .and. j <= nlev_improad(l)) then - heat_dry_mass(c) = heat_dry_mass(c) + & - TempToHeat(t_soisno(c,j),(cv_improad(l,j) * dz(c,j))) + + sum_dry = sum_dry + TempToHeat(t_soisno(c,j),(cv_improad(l,j) * dz(c,j))) + else if (lun_pp%itype(l) /= istwet .and. lun_pp%itype(l) /= istice .and. lun_pp%itype(l) /= istice_mec) then ! Note that this also includes impervious roads below nlev_improad (where ! we have soil) - heat_dry_mass(c) = heat_dry_mass(c) + & + sum_dry = sum_dry + & TempToHeat( t_soisno(c,j), (csol(c,j)*(1-watsat(c,j))*dz(c,j))) end if end if @@ -598,20 +657,36 @@ subroutine ComputeHeatNonLake(bounds, num_nolakec, filter_nolakec, & call AccumulateLiquidWaterHeat( & temp = t_soisno(c,j), & h2o = h2osoi_liq(c,j), & - cv_liquid = cv_liquid(c), & - heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) - heat_ice(c) = heat_ice(c) + & + cv_liquid = sum_cv, & + heat_liquid = sum_heat, & + latent_heat_liquid = sum_latent) + + sum_hice = sum_hice + & TempToHeat(t_soisno(c,j), (h2osoi_ice(c,j)*cpice)) end if end do + + heat_dry_mass(fc) = sum_dry + cv_liquid(c) = cv_liquid(c) + sum_cv + heat_liquid(c) = heat_liquid(c) + sum_heat + latent_heat_liquid(fc) = latent_heat_liquid(fc) + sum_latent + heat_ice(fc) = heat_ice(fc) + sum_hice end do + !$acc parallel loop independent gang vector default(present) do fc = 1, num_nolakec c = filter_nolakec(fc) - heat(c) = heat_dry_mass(c) + heat_ice(c) + heat_liquid(c) + latent_heat_liquid(c) + heat(c) = heat_dry_mass(fc) + heat_ice(fc) + heat_liquid(c) + latent_heat_liquid(fc) end do + !$acc exit data delete(& + !$acc h2ocan_col(:), & + !$acc heat_dry_mass(:), & + !$acc heat_ice(:), & + !$acc latent_heat_liquid(:), & + !$acc sum_hice, & + !$acc sum_dry) + end associate end subroutine ComputeHeatNonLake @@ -633,7 +708,7 @@ subroutine ComputeHeatLake(bounds, num_lakec, filter_lakec, & ! generally be accompanied by similar changes to ComputeLiqIceMassLake ! ! !ARGUMENTS: - !$acc routine seq + type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_lakec integer , intent(in) :: filter_lakec(:) @@ -647,17 +722,15 @@ subroutine ComputeHeatLake(bounds, num_lakec, filter_lakec, & integer :: fc integer :: c,j - real(r8) :: heat_dry_mass(bounds%begc:bounds%endc) ! sum of heat content: dry mass [J/m^2] - real(r8) :: heat_ice(bounds%begc:bounds%endc) ! sum of heat content: ice [J/m^2] - real(r8) :: latent_heat_liquid(bounds%begc:bounds%endc) ! sum of latent heat content of liquid water [J/m^2] + real(r8) :: heat_dry_mass(1:num_lakec) ! sum of heat content: dry mass [J/m^2] + real(r8) :: heat_ice(1:num_lakec) ! sum of heat content: ice [J/m^2] + real(r8) :: latent_heat_liquid(1:num_lakec) ! sum of latent heat content of liquid water [J/m^2] + + real(r8) :: sum_heat,sum_cv,sum_latent, sum_hice, sum_dry !character(len=*), parameter :: subname = 'ComputeHeatLake' !----------------------------------------------------------------------- - - !SHR_ASSERT_ALL((ubound(heat) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - !SHR_ASSERT_ALL((ubound(heat_liquid) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - !SHR_ASSERT_ALL((ubound(cv_liquid) == (/bounds%endc/)), errMsg(sourcefile, __LINE__)) - + associate( & snl => col_pp%snl, & ! number of snow layers dz => col_pp%dz, & ! layer depth (m) @@ -668,66 +741,111 @@ subroutine ComputeHeatLake(bounds, num_lakec, filter_lakec, & h2osoi_ice => col_ws%h2osoi_ice, & ! frozen water (kg/m2) h2osno => col_ws%h2osno & ! snow water (mm H2O) ) + !$acc enter data create(& + !$acc heat_dry_mass(:), & + !$acc heat_ice(:), & + !$acc latent_heat_liquid(:), & + !$acc sum_hice, & + !$acc sum_dry) + + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) heat_liquid(c) = 0._r8 cv_liquid(c) = 0._r8 - heat_dry_mass(c) = 0._r8 - heat_ice(c) = 0._r8 - latent_heat_liquid(c) = 0._r8 + + heat_dry_mass(fc) = 0._r8 + heat_ice(fc) = 0._r8 + latent_heat_liquid(fc) = 0._r8 end do ! Snow heat content + !$acc parallel loop independent gang worker default(present) private(sum_heat,sum_cv,sum_latent,sum_hice) do fc = 1, num_lakec c = filter_lakec(fc) + sum_heat = 0._r8 + sum_cv = 0._r8 + sum_latent = 0._r8 + sum_hice = 0._r8 if ( snl(c) < 0 ) then - ! Loop over snow layers + ! Loop over snow layers + !$acc loop vector reduction(+:sum_heat,sum_cv,sum_latent, sum_hice) do j = snl(c)+1,0 call AccumulateLiquidWaterHeat( & temp = t_soisno(c,j), & h2o = h2osoi_liq(c,j), & - cv_liquid = cv_liquid(c), & - heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) - heat_ice(c) = heat_ice(c) + & + cv_liquid = sum_cv, & + heat_liquid = sum_heat, & + latent_heat_liquid = sum_latent) + + sum_hice = sum_hice + & TempToHeat(t_soisno(c,j), (h2osoi_ice(c,j)*cpice)) end do - else if (h2osno(c) /= 0._r8) then - ! TODO(wjs, 2017-03-16) (Copying this note from old code... I'm not positive - ! it's still true.) The heat capacity (not latent heat) of snow without snow - ! layers is currently ignored in LakeTemperature, so it should be ignored here. - ! Eventually we should consider this. + + ! else if (h2osno(c) /= 0._r8) then + ! ! TODO(wjs, 2017-03-16) (Copying this note from old code... I'm not positive + ! ! it's still true.) The heat capacity (not latent heat) of snow without snow + ! ! layers is currently ignored in LakeTemperature, so it should be ignored here. + ! ! Eventually we should consider this. end if + cv_liquid(c) = sum_cv + heat_liquid(c) = sum_heat + latent_heat_liquid(fc) = sum_latent + heat_ice(fc) = sum_hice end do ! Soil water content of the soil under the lake - do j = 1,nlevgrnd - do fc = 1, num_lakec - c = filter_lakec(fc) + !$acc parallel loop independent gang worker default(present) private(sum_heat,sum_cv,sum_latent,sum_hice,sum_dry) + do fc = 1, num_lakec + c = filter_lakec(fc) + sum_heat = 0._r8 + sum_cv = 0._r8 + sum_latent = 0._r8 + sum_hice = 0._r8 + sum_dry = 0._r8 - heat_dry_mass(c) = heat_dry_mass(c) + & - TempToHeat( t_soisno(c,j), (csol(c,j)*(1-watsat(c,j))*dz(c,j))) - call AccumulateLiquidWaterHeat( & + !$acc loop vector reduction(+:sum_heat,sum_cv,sum_latent, sum_hice,sum_dry) + do j = 1,nlevgrnd + + sum_dry = sum_dry + TempToHeat( t_soisno(c,j), (csol(c,j)*(1-watsat(c,j))*dz(c,j))) + + call AccumulateLiquidWaterHeat( & temp = t_soisno(c,j), & h2o = h2osoi_liq(c,j), & - cv_liquid = cv_liquid(c), & - heat_liquid = heat_liquid(c), & - latent_heat_liquid = latent_heat_liquid(c)) - heat_ice(c) = heat_ice(c) + & + cv_liquid = sum_cv, & + heat_liquid = sum_heat, & + latent_heat_liquid = sum_latent) + + sum_hice = sum_hice + & TempToHeat(t_soisno(c,j), (h2osoi_ice(c,j)*cpice)) end do + heat_dry_mass(fc) = sum_dry + + cv_liquid(c) = cv_liquid(c) + sum_cv + heat_liquid(c) = heat_liquid(c) + sum_heat + latent_heat_liquid(fc) = latent_heat_liquid(fc) + sum_latent + heat_ice(fc) = heat_ice(fc) + sum_hice + end do ! TODO(wjs, 2017-03-11) Include heat content of water in lakes, once we include ! lake water as an explicit water state (https://github.com/NCAR/CLM/issues/2) + !$acc parallel loop independent gang vector default(present) do fc = 1, num_lakec c = filter_lakec(fc) - heat(c) = heat_dry_mass(c) + heat_ice(c) + heat_liquid(c) + latent_heat_liquid(c) + heat(c) = heat_dry_mass(fc) + heat_ice(fc) + heat_liquid(c) + latent_heat_liquid(fc) end do + !$acc exit data delete(& + !$acc heat_dry_mass(:), & + !$acc heat_ice(:), & + !$acc latent_heat_liquid(:), & + !$acc sum_hice, & + !$acc sum_dry) + end associate end subroutine ComputeHeatLake @@ -833,8 +951,8 @@ function LiquidWaterHeat(temp, h2o) result(heat) ! a given temperature, using a base temperature of heat_base_temp. ! ! !USES: - ! - ! !ARGUMENTS: + !$acc routine seq + ! !ARGUMENTS: real(r8) :: heat ! function result real(r8), intent(in) :: temp ! temperature [K] real(r8), intent(in) :: h2o ! water mass [kg/m^2] @@ -865,7 +983,8 @@ subroutine AccumulateLiquidWaterHeat(temp, h2o, & ! count for liquid water, for a single column ! ! !ARGUMENTS: - !$acc routine seq + + !$acc routine seq real(r8), intent(in) :: temp ! temperature [K] real(r8), intent(in) :: h2o ! water mass [kg/m^2] diff --git a/components/elm/src/biogeophys/TridiagonalMod.F90 b/components/elm/src/biogeophys/TridiagonalMod.F90 index d4c493ac5ace..9512e6277f60 100644 --- a/components/elm/src/biogeophys/TridiagonalMod.F90 +++ b/components/elm/src/biogeophys/TridiagonalMod.F90 @@ -10,6 +10,7 @@ module TridiagonalMod ! ! !PUBLIC MEMBER FUNCTIONS: public :: Tridiagonal + public :: Tridiagonal_filter public :: trisim interface Tridiagonal module procedure Tridiagonal_sr @@ -100,6 +101,69 @@ subroutine Tridiagonal_sr (bounds, lbj, ubj, jtop, numf, filter, a, b, c, r, u, end subroutine Tridiagonal_sr + subroutine Tridiagonal_filter (lbj, ubj, jtop, numf, filter, a, b, c, r, u) + ! !DESCRIPTION: + ! Tridiagonal matrix solution + ! A x = r + ! where x and r are vectors + ! !USES: + use shr_kind_mod , only: r8 => shr_kind_r8 + ! + ! !ARGUMENTS: + implicit none + integer , intent(in) :: lbj, ubj ! lbinning and ubing level indices + integer , intent(in) :: jtop ! top level for each column [col] + integer , intent(in) :: numf ! filter dimension + integer , intent(in) :: filter(:) ! filter + real(r8) , intent(in) :: a( 1:numf , lbj:ubj) ! "a" left off diagonal of tridiagonal matrix [col , j] + real(r8) , intent(in) :: b( 1:numf , lbj:ubj) ! "b" diagonal column for tridiagonal matrix [col , j] + real(r8) , intent(in) :: c( 1:numf , lbj:ubj) ! "c" right off diagonal tridiagonal matrix [col , j] + real(r8) , intent(in) :: r( 1:numf , lbj:ubj) ! "r" forcing term of tridiagonal matrix [col , j] + real(r8) , intent(inout) :: u( 1:numf , lbj:ubj) ! solution [col , j] + !==========================================================! + integer :: j,ci ! indices + real(r8) :: gam(lbj:ubj) ! temporary + real(r8) :: bet ! temporary + !----------------------------------------------------------------------- + ! Solve the matrix + !----------------------------------------------------------------------- + + + !$acc enter data create(& + !$acc gam(:)) + + !$acc parallel loop independent gang vector default(present) & + !$acc present(a(:,:),b(:,:),c(:,:),r(:,:),u(:,:)) private(bet,gam(:)) + do ci = 1,numf + bet = b(ci,jtop) + + !$acc loop seq + do j = lbj, ubj + if (j >= jtop) then + if (j == jtop) then + u(ci,j) = r(ci,j) / bet + else + gam(j) = c(ci,j-1) / bet + bet = b(ci,j) - a(ci,j) * gam(j) + u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet + end if + end if + end do + + !$acc loop seq + do j = ubj-1,lbj,-1 + if (j >= jtop) then + u(ci,j) = u(ci,j) - gam(j+1) * u(ci,j+1) + end if + end do + + end do + + !$acc exit data delete(& + !$acc gam(:)) + + end subroutine Tridiagonal_filter + !----------------------------------------------------------------------- subroutine Tridiagonal_mr (bounds, lbj, ubj, jtop, numf, filter, ntrcs, a, b, c, r, u, is_col_active) !$acc routine seq @@ -189,7 +253,6 @@ end subroutine Tridiagonal_mr !---------------- subroutine Trisim(bounds, lbj, ubj, numf, filter, a1,b1,c1,d1,e1,a2,b2,c2,d2,e2,w1, w2) - !$acc routine seq !DESCRIPTIONS ! This subroutine solves two coupled tridiagonal equations ! A1*W1(J-1)+B1*W1(j)+C1*W1(J+1) = D1*W2(j) + E1 AND @@ -343,11 +406,11 @@ subroutine Tridiagonal_sr_with_var_bottom (bounds, lbj, ubj, jtop, jbot, numf, f integer , intent(in) :: jbot( bounds%begc: bounds%endc) ! top level for each column [col] integer , intent(in) :: numf ! filter dimension integer , intent(in) :: filter(:) ! filter - real(r8) , intent(in) :: a( bounds%begc:bounds%endc , lbj:ubj) ! "a" left off diagonal of tridiagonal matrix [col , j] - real(r8) , intent(in) :: b( bounds%begc:bounds%endc , lbj:ubj) ! "b" diagonal column for tridiagonal matrix [col , j] - real(r8) , intent(in) :: c( bounds%begc:bounds%endc , lbj:ubj) ! "c" right off diagonal tridiagonal matrix [col , j] - real(r8) , intent(in) :: r( bounds%begc:bounds%endc , lbj:ubj) ! "r" forcing term of tridiagonal matrix [col , j] - real(r8) , intent(inout) :: u( bounds%begc:bounds%endc , lbj:ubj) ! solution [col , j] + real(r8) , intent(in) :: a( 1:numf , lbj:ubj) ! "a" left off diagonal of tridiagonal matrix [col , j] + real(r8) , intent(in) :: b( 1:numf , lbj:ubj) ! "b" diagonal column for tridiagonal matrix [col , j] + real(r8) , intent(in) :: c( 1:numf , lbj:ubj) ! "c" right off diagonal tridiagonal matrix [col , j] + real(r8) , intent(in) :: r( 1:numf , lbj:ubj) ! "r" forcing term of tridiagonal matrix [col , j] + real(r8) , intent(inout) :: u( 1:numf , lbj:ubj) ! solution [col , j] ! integer :: j,ci,fc ! indices logical, optional, intent(in) :: is_col_active(bounds%begc:bounds%endc) ! @@ -369,7 +432,7 @@ subroutine Tridiagonal_sr_with_var_bottom (bounds, lbj, ubj, jtop, jbot, numf, f do fc = 1,numf ci = filter(fc) if(l_is_col_active(ci))then - bet(ci) = b(ci,jtop(ci)) + bet(ci) = b(fc,jtop(ci)) endif end do @@ -379,11 +442,11 @@ subroutine Tridiagonal_sr_with_var_bottom (bounds, lbj, ubj, jtop, jbot, numf, f if(l_is_col_active(ci))then if (j >= jtop(ci) .and. j <= jbot(ci)) then if (j == jtop(ci)) then - u(ci,j) = r(ci,j) / bet(ci) + u(fc,j) = r(fc,j) / bet(ci) else - gam(ci,j) = c(ci,j-1) / bet(ci) - bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j) - u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci) + gam(ci,j) = c(fc,j-1) / bet(ci) + bet(ci) = b(fc,j) - a(fc,j) * gam(ci,j) + u(fc,j) = (r(fc,j) - a(fc,j)*u(fc,j-1)) / bet(ci) end if end if endif @@ -395,7 +458,7 @@ subroutine Tridiagonal_sr_with_var_bottom (bounds, lbj, ubj, jtop, jbot, numf, f ci = filter(fc) if(l_is_col_active(ci))then if (j >= jtop(ci) .and. j <= jbot(ci)-1) then - u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1) + u(fc,j) = u(fc,j) - gam(ci,j+1) * u(fc,j+1) end if endif end do diff --git a/components/elm/src/biogeophys/UrbanFluxesMod.F90 b/components/elm/src/biogeophys/UrbanFluxesMod.F90 index efb8abf9bf84..4405b7714a41 100644 --- a/components/elm/src/biogeophys/UrbanFluxesMod.F90 +++ b/components/elm/src/biogeophys/UrbanFluxesMod.F90 @@ -14,7 +14,7 @@ module UrbanFluxesMod use elm_varctl , only : iulog use abortutils , only : endrun use UrbanParamsType , only : urbanparams_type - use UrbanParamsType , only : urban_wasteheat_on, urban_hac_on, urban_hac + use UrbanParamsType , only : urban_wasteheat_int, urban_hac_on_int, urban_hac_int,urban_hac_off_int use atm2lndType , only : atm2lnd_type use SoilStateType , only : soilstate_type use FrictionVelocityType , only : frictionvel_type @@ -30,7 +30,7 @@ module UrbanFluxesMod use VegetationDataType , only : veg_es, veg_ef, veg_ws, veg_wf use elm_time_manager , only : get_curr_date, get_step_size, get_nstep - use timeinfoMod , only : nstep_mod, year_curr, mon_curr, day_curr, secs_curr + use timeinfoMod , only : nstep_mod, secs_curr use timeinfoMod , only : dtime_mod ! @@ -42,29 +42,30 @@ module UrbanFluxesMod ! !PUBLIC MEMBER FUNCTIONS: public :: UrbanFluxes ! Urban physics - turbulent fluxes !----------------------------------------------------------------------- - + integer, parameter :: urban_hac_off_int = 0 + integer, parameter :: urban_hac_on_int = 1 + integer, parameter :: urban_wasteheat_on_int = 2 + integer, public :: urban_hac_int = urban_hac_off_int contains !----------------------------------------------------------------------- - subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, & + subroutine UrbanFluxes (bounds, & num_urbanl, filter_urbanl, num_urbanc, filter_urbanc, num_urbanp, filter_urbanp, & - atm2lnd_vars, urbanparams_vars, soilstate_vars, & - frictionvel_vars, energyflux_vars ) + urbanparams_vars, soilstate_vars, & + frictionvel_vars ) ! ! !DESCRIPTION: ! Turbulent and momentum fluxes from urban canyon (consisting of roof, sunwall, ! shadewall, pervious and impervious road). ! !USES: - !$acc routine seq - use shr_flux_mod , only : shr_flux_update_stress use elm_varcon , only : cpair, vkc, spval, grav, pondmx_urban, rpi, rgas use elm_varcon , only : ht_wasteheat_factor, ac_wasteheat_factor, wasteheat_limit use column_varcon , only : icol_shadewall, icol_road_perv, icol_road_imperv use column_varcon , only : icol_roof, icol_sunwall use filterMod , only : filter - use FrictionVelocityMod , only : FrictionVelocity, MoninObukIni, & + use FrictionVelocityMod , only : FrictionVelocity_loops, MoninObukIni, & implicit_stress, atm_gustiness, force_land_gustiness use QSatMod , only : QSat use elm_varpar , only : maxpatch_urb, nlevurb, nlevgrnd @@ -72,116 +73,106 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, ! ! !ARGUMENTS: type(bounds_type) , intent(in) :: bounds - integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump - integer , intent(in) :: filter_nourbanl(:) ! non-urban landunit filter integer , intent(in) :: num_urbanl ! number of urban landunits in clump integer , intent(in) :: filter_urbanl(:) ! urban landunit filter integer , intent(in) :: num_urbanc ! number of urban columns in clump integer , intent(in) :: filter_urbanc(:) ! urban column filter integer , intent(in) :: num_urbanp ! number of urban patches in clump integer , intent(in) :: filter_urbanp(:) ! urban pft filter - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(urbanparams_type) , intent(in) :: urbanparams_vars type(soilstate_type) , intent(inout) :: soilstate_vars type(frictionvel_type) , intent(inout) :: frictionvel_vars - type(energyflux_type) , intent(inout) :: energyflux_vars - real(r8) :: dtime ! land model time step (sec) - integer :: year,month,day,secs ! ! !LOCAL VARIABLES: integer :: fp,fc,fl,f,p,c,l,t,g,j,pi,i ! indices - integer :: filterl_copy(num_urbanl) ! iteration copy of filter_urbanl - integer :: filterc_copy(num_urbanc) ! iteration copy of filter_urbanc - integer :: fnl_iter ! iteration num_urbanl - integer :: fnl_iter_old ! previous iteration fnl_iter - integer :: fnc_iter ! iteration num_urbanc - integer :: fnc_iter_old ! previous iteration fnc_iter - - real(r8) :: canyontop_wind(bounds%begl:bounds%endl) ! wind at canyon top (m/s) - real(r8) :: canyon_u_wind(bounds%begl:bounds%endl) ! u-component of wind speed inside canyon (m/s) - real(r8) :: canyon_wind(bounds%begl:bounds%endl) ! net wind speed inside canyon (m/s) - real(r8) :: canyon_resistance(bounds%begl:bounds%endl) ! resistance to heat and moisture transfer from canyon road/walls to canyon air (s/m) - - real(r8) :: ur(bounds%begl:bounds%endl) ! wind speed at reference height (m/s) - real(r8) :: ustar(bounds%begl:bounds%endl) ! friction velocity (m/s) - real(r8) :: ramu(bounds%begl:bounds%endl) ! aerodynamic resistance (s/m) - real(r8) :: rahu(bounds%begl:bounds%endl) ! thermal resistance (s/m) - real(r8) :: rawu(bounds%begl:bounds%endl) ! moisture resistance (s/m) - real(r8) :: temp1(bounds%begl:bounds%endl) ! relation for potential temperature profile - real(r8) :: temp12m(bounds%begl:bounds%endl) ! relation for potential temperature profile applied at 2-m - real(r8) :: temp2(bounds%begl:bounds%endl) ! relation for specific humidity profile - real(r8) :: temp22m(bounds%begl:bounds%endl) ! relation for specific humidity profile applied at 2-m - real(r8) :: thm_g(bounds%begl:bounds%endl) ! intermediate variable (forc_t+0.0098*forc_hgt_t) - real(r8) :: thv_g(bounds%begl:bounds%endl) ! virtual potential temperature (K) - real(r8) :: dth(bounds%begl:bounds%endl) ! diff of virtual temp. between ref. height and surface - real(r8) :: dqh(bounds%begl:bounds%endl) ! diff of humidity between ref. height and surface - real(r8) :: zldis(bounds%begl:bounds%endl) ! reference height "minus" zero displacement height (m) - real(r8) :: um(bounds%begl:bounds%endl) ! wind speed including the stablity effect (m/s) - real(r8) :: obu(bounds%begl:bounds%endl) ! Obukhov length scale (m) - real(r8) :: taf_numer(bounds%begl:bounds%endl) ! numerator of taf equation (K m/s) - real(r8) :: taf_denom(bounds%begl:bounds%endl) ! denominator of taf equation (m/s) - real(r8) :: qaf_numer(bounds%begl:bounds%endl) ! numerator of qaf equation (kg m/kg s) - real(r8) :: qaf_denom(bounds%begl:bounds%endl) ! denominator of qaf equation (m/s) - real(r8) :: wtas(bounds%begl:bounds%endl) ! sensible heat conductance for urban air to atmospheric air (m/s) - real(r8) :: wtaq(bounds%begl:bounds%endl) ! latent heat conductance for urban air to atmospheric air (m/s) - real(r8) :: wts_sum(bounds%begl:bounds%endl) ! sum of wtas, wtus_roof, wtus_road_perv, wtus_road_imperv, wtus_sunwall, wtus_shadewall - real(r8) :: wtq_sum(bounds%begl:bounds%endl) ! sum of wtaq, wtuq_roof, wtuq_road_perv, wtuq_road_imperv, wtuq_sunwall, wtuq_shadewall - real(r8) :: beta(bounds%begl:bounds%endl) ! coefficient of convective velocity - real(r8) :: zii(bounds%begl:bounds%endl) ! convective boundary layer height (m) - real(r8) :: fm(bounds%begl:bounds%endl) ! needed for BGC only to diagnose 10m wind speed - real(r8) :: wtus(bounds%begc:bounds%endc) ! sensible heat conductance for urban columns (scaled) (m/s) - real(r8) :: wtuq(bounds%begc:bounds%endc) ! latent heat conductance for urban columns (scaled) (m/s) + integer :: num_copyl ! iteration num_urbanl + integer :: num_copyl_old ! previous iteration num_copyl + integer :: num_copyc ! iteration num_urbanc + integer :: num_copyc_old ! previous iteration num_copyc + integer :: num_unconverged + + real(r8) :: canyontop_wind(1:num_urbanl) ! wind at canyon top (m/s) + real(r8) :: canyon_u_wind(1:num_urbanl) ! u-component of wind speed inside canyon (m/s) + real(r8) :: canyon_wind(1:num_urbanl) ! net wind speed inside canyon (m/s) + real(r8) :: canyon_resistance(1:num_urbanl) ! resistance to heat and moisture transfer from canyon road/walls to canyon air (s/m) + + real(r8) :: ur(1:num_urbanl) ! wind speed at reference height (m/s) + real(r8) :: ustar(1:num_urbanl) ! friction velocity (m/s) + real(r8) :: ramu(1:num_urbanl) ! aerodynamic resistance (s/m) + real(r8) :: rahu(1:num_urbanl) ! thermal resistance (s/m) + real(r8) :: rawu(1:num_urbanl) ! moisture resistance (s/m) + real(r8) :: temp1(1:num_urbanl) ! relation for potential temperature profile + real(r8) :: temp12m(1:num_urbanl) ! relation for potential temperature profile applied at 2-m + real(r8) :: temp2(1:num_urbanl) ! relation for specific humidity profile + real(r8) :: temp22m(1:num_urbanl) ! relation for specific humidity profile applied at 2-m + real(r8) :: thm_g(1:num_urbanl) ! intermediate variable (forc_t+0.0098*forc_hgt_t) + real(r8) :: thv_g(1:num_urbanl) ! virtual potential temperature (K) + real(r8) :: dth(1:num_urbanl) ! diff of virtual temp. between ref. height and surface + real(r8) :: dqh(1:num_urbanl) ! diff of humidity between ref. height and surface + real(r8) :: zldis(1:num_urbanl) ! reference height "minus" zero displacement height (m) + real(r8) :: um(1:num_urbanl) ! wind speed including the stablity effect (m/s) + real(r8) :: obu(1:num_urbanl) ! Monin-Obukhov length (m) + real(r8) :: taf_numer(1:num_urbanl) ! numerator of taf equation (K m/s) + real(r8) :: taf_denom(1:num_urbanl) ! denominator of taf equation (m/s) + real(r8) :: qaf_numer(1:num_urbanl) ! numerator of qaf equation (kg m/kg s) + real(r8) :: qaf_denom(1:num_urbanl) ! denominator of qaf equation (m/s) + real(r8) :: wtas(1:num_urbanl) ! sensible heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wtaq(1:num_urbanl) ! latent heat conductance for urban air to atmospheric air (m/s) + real(r8) :: wts_sum(1:num_urbanl) ! sum of wtas, wtus_roof, wtus_road_perv, wtus_road_imperv, wtus_sunwall, wtus_shadewall + real(r8) :: wtq_sum(1:num_urbanl) ! sum of wtaq, wtuq_roof, wtuq_road_perv, wtuq_road_imperv, wtuq_sunwall, wtuq_shadewall + real(r8) :: fm(1:num_urbanl) ! needed for BGC only to diagnose 10m wind speed + real(r8) :: wtus(1:num_urbanc) ! sensible heat conductance for urban columns (scaled) (m/s) + real(r8) :: wtuq(1:num_urbanc) ! latent heat conductance for urban columns (scaled) (m/s) integer :: iter ! iteration index integer :: iter_final ! number of iterations used real(r8) :: dthv ! diff of vir. poten. temp. between ref. height and surface real(r8) :: tstar ! temperature scaling parameter real(r8) :: qstar ! moisture scaling parameter real(r8) :: thvstar ! virtual potential temperature scaling parameter - real(r8) :: wtus_roof(bounds%begl:bounds%endl) ! sensible heat conductance for roof (scaled) (m/s) - real(r8) :: wtuq_roof(bounds%begl:bounds%endl) ! latent heat conductance for roof (scaled) (m/s) - real(r8) :: wtus_road_perv(bounds%begl:bounds%endl) ! sensible heat conductance for pervious road (scaled) (m/s) - real(r8) :: wtuq_road_perv(bounds%begl:bounds%endl) ! latent heat conductance for pervious road (scaled) (m/s) - real(r8) :: wtus_road_imperv(bounds%begl:bounds%endl) ! sensible heat conductance for impervious road (scaled) (m/s) - real(r8) :: wtuq_road_imperv(bounds%begl:bounds%endl) ! latent heat conductance for impervious road (scaled) (m/s) - real(r8) :: wtus_sunwall(bounds%begl:bounds%endl) ! sensible heat conductance for sunwall (scaled) (m/s) - real(r8) :: wtuq_sunwall(bounds%begl:bounds%endl) ! latent heat conductance for sunwall (scaled) (m/s) - real(r8) :: wtus_shadewall(bounds%begl:bounds%endl) ! sensible heat conductance for shadewall (scaled) (m/s) - real(r8) :: wtuq_shadewall(bounds%begl:bounds%endl) ! latent heat conductance for shadewall (scaled) (m/s) - real(r8) :: wtus_roof_unscl(bounds%begl:bounds%endl) ! sensible heat conductance for roof (not scaled) (m/s) - real(r8) :: wtuq_roof_unscl(bounds%begl:bounds%endl) ! latent heat conductance for roof (not scaled) (m/s) - real(r8) :: wtus_road_perv_unscl(bounds%begl:bounds%endl) ! sensible heat conductance for pervious road (not scaled) (m/s) - real(r8) :: wtuq_road_perv_unscl(bounds%begl:bounds%endl) ! latent heat conductance for pervious road (not scaled) (m/s) - real(r8) :: wtus_road_imperv_unscl(bounds%begl:bounds%endl) ! sensible heat conductance for impervious road (not scaled) (m/s) - real(r8) :: wtuq_road_imperv_unscl(bounds%begl:bounds%endl) ! latent heat conductance for impervious road (not scaled) (m/s) - real(r8) :: wtus_sunwall_unscl(bounds%begl:bounds%endl) ! sensible heat conductance for sunwall (not scaled) (m/s) - real(r8) :: wtuq_sunwall_unscl(bounds%begl:bounds%endl) ! latent heat conductance for sunwall (not scaled) (m/s) - real(r8) :: wtus_shadewall_unscl(bounds%begl:bounds%endl) ! sensible heat conductance for shadewall (not scaled) (m/s) - real(r8) :: wtuq_shadewall_unscl(bounds%begl:bounds%endl) ! latent heat conductance for shadewall (not scaled) (m/s) - real(r8) :: t_sunwall_innerl(bounds%begl:bounds%endl) ! temperature of inner layer of sunwall (K) - real(r8) :: t_shadewall_innerl(bounds%begl:bounds%endl) ! temperature of inner layer of shadewall (K) - real(r8) :: t_roof_innerl(bounds%begl:bounds%endl) ! temperature of inner layer of roof (K) + real(r8) :: wtus_roof(1:num_urbanl) ! sensible heat conductance for roof (scaled) (m/s) + real(r8) :: wtuq_roof(1:num_urbanl) ! latent heat conductance for roof (scaled) (m/s) + real(r8) :: wtus_road_perv(1:num_urbanl) ! sensible heat conductance for pervious road (scaled) (m/s) + real(r8) :: wtuq_road_perv(1:num_urbanl) ! latent heat conductance for pervious road (scaled) (m/s) + real(r8) :: wtus_road_imperv(1:num_urbanl) ! sensible heat conductance for impervious road (scaled) (m/s) + real(r8) :: wtuq_road_imperv(1:num_urbanl) ! latent heat conductance for impervious road (scaled) (m/s) + real(r8) :: wtus_sunwall(1:num_urbanl) ! sensible heat conductance for sunwall (scaled) (m/s) + real(r8) :: wtuq_sunwall(1:num_urbanl) ! latent heat conductance for sunwall (scaled) (m/s) + real(r8) :: wtus_shadewall(1:num_urbanl) ! sensible heat conductance for shadewall (scaled) (m/s) + real(r8) :: wtuq_shadewall(1:num_urbanl) ! latent heat conductance for shadewall (scaled) (m/s) + real(r8) :: wtus_roof_unscl(1:num_urbanl) ! sensible heat conductance for roof (not scaled) (m/s) + real(r8) :: wtuq_roof_unscl(1:num_urbanl) ! latent heat conductance for roof (not scaled) (m/s) + real(r8) :: wtus_road_perv_unscl(1:num_urbanl) ! sensible heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtuq_road_perv_unscl(1:num_urbanl) ! latent heat conductance for pervious road (not scaled) (m/s) + real(r8) :: wtus_road_imperv_unscl(1:num_urbanl) ! sensible heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtuq_road_imperv_unscl(1:num_urbanl) ! latent heat conductance for impervious road (not scaled) (m/s) + real(r8) :: wtus_sunwall_unscl(1:num_urbanl) ! sensible heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtuq_sunwall_unscl(1:num_urbanl) ! latent heat conductance for sunwall (not scaled) (m/s) + real(r8) :: wtus_shadewall_unscl(1:num_urbanl) ! sensible heat conductance for shadewall (not scaled) (m/s) + real(r8) :: wtuq_shadewall_unscl(1:num_urbanl) ! latent heat conductance for shadewall (not scaled) (m/s) + real(r8) :: t_sunwall_innerl(1:num_urbanl) ! temperature of inner layer of sunwall (K) + real(r8) :: t_shadewall_innerl(1:num_urbanl) ! temperature of inner layer of shadewall (K) + real(r8) :: t_roof_innerl(1:num_urbanl) ! temperature of inner layer of roof (K) real(r8) :: lngth_roof ! length of roof (m) real(r8) :: wc ! convective velocity (m/s) - real(r8) :: ugust_total(bounds%begl:bounds%endl) ! gustiness including convective velocity [m/s] real(r8) :: zeta ! dimensionless height used in Monin-Obukhov theory real(r8) :: eflx_sh_grnd_scale(bounds%begp:bounds%endp) ! scaled sensible heat flux from ground (W/m**2) [+ to atm] real(r8) :: qflx_evap_soi_scale(bounds%begp:bounds%endp) ! scaled soil evaporation (mm H2O/s) (+ = to atm) - real(r8) :: eflx_wasteheat_roof(bounds%begl:bounds%endl) ! sensible heat flux from urban heating/cooling sources of waste heat for roof (W/m**2) - real(r8) :: eflx_wasteheat_sunwall(bounds%begl:bounds%endl) ! sensible heat flux from urban heating/cooling sources of waste heat for sunwall (W/m**2) - real(r8) :: eflx_wasteheat_shadewall(bounds%begl:bounds%endl) ! sensible heat flux from urban heating/cooling sources of waste heat for shadewall (W/m**2) - real(r8) :: eflx_heat_from_ac_roof(bounds%begl:bounds%endl) ! sensible heat flux put back into canyon due to heat removal by AC for roof (W/m**2) - real(r8) :: eflx_heat_from_ac_sunwall(bounds%begl:bounds%endl) ! sensible heat flux put back into canyon due to heat removal by AC for sunwall (W/m**2) - real(r8) :: eflx_heat_from_ac_shadewall(bounds%begl:bounds%endl) ! sensible heat flux put back into canyon due to heat removal by AC for shadewall (W/m**2) - real(r8) :: eflx(bounds%begl:bounds%endl) ! total sensible heat flux for error check (W/m**2) - real(r8) :: qflx(bounds%begl:bounds%endl) ! total water vapor flux for error check (kg/m**2/s) - real(r8) :: eflx_scale(bounds%begl:bounds%endl) ! sum of scaled sensible heat fluxes for urban columns for error check (W/m**2) - real(r8) :: qflx_scale(bounds%begl:bounds%endl) ! sum of scaled water vapor fluxes for urban columns for error check (kg/m**2/s) - real(r8) :: eflx_err(bounds%begl:bounds%endl) ! sensible heat flux error (W/m**2) - real(r8) :: qflx_err(bounds%begl:bounds%endl) ! water vapor flux error (kg/m**2/s) + real(r8) :: eflx_wasteheat_roof(1:num_urbanl) ! sensible heat flux from urban heating/cooling sources of waste heat for roof (W/m**2) + real(r8) :: eflx_wasteheat_sunwall(1:num_urbanl) ! sensible heat flux from urban heating/cooling sources of waste heat for sunwall (W/m**2) + real(r8) :: eflx_wasteheat_shadewall(1:num_urbanl) ! sensible heat flux from urban heating/cooling sources of waste heat for shadewall (W/m**2) + real(r8) :: eflx_heat_from_ac_roof(1:num_urbanl) ! sensible heat flux put back into canyon due to heat removal by AC for roof (W/m**2) + real(r8) :: eflx_heat_from_ac_sunwall(1:num_urbanl) ! sensible heat flux put back into canyon due to heat removal by AC for sunwall (W/m**2) + real(r8) :: eflx_heat_from_ac_shadewall(1:num_urbanl) ! sensible heat flux put back into canyon due to heat removal by AC for shadewall (W/m**2) + real(r8) :: eflx(1:num_urbanl) ! total sensible heat flux for error check (W/m**2) + real(r8) :: qflx(1:num_urbanl) ! total water vapor flux for error check (kg/m**2/s) + real(r8) :: eflx_scale(1:num_urbanl) ! sum of scaled sensible heat fluxes for urban columns for error check (W/m**2) + real(r8) :: qflx_scale(1:num_urbanl) ! sum of scaled water vapor fluxes for urban columns for error check (kg/m**2/s) + real(r8) :: eflx_err(1:num_urbanl) ! sensible heat flux error (W/m**2) + real(r8) :: qflx_err(1:num_urbanl) ! water vapor flux error (kg/m**2/s) real(r8) :: fwet_roof ! fraction of roof surface that is wet (-) real(r8) :: fwet_road_imperv ! fraction of impervious road surface that is wet (-) - integer :: local_secp1(bounds%begl:bounds%endl) ! seconds into current date in local time (sec) + integer :: local_secp1(1:num_urbanl) ! seconds into current date in local time (sec) ! calendar info for current time step logical :: found ! flag in search loop integer :: indexl ! index of first found in search loop @@ -196,31 +187,39 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, integer, parameter :: itmin = 3 ! minimum number of iterations integer, parameter :: itmax = 30 ! maximum number of iterations integer :: loopmax ! bound for iteration loop - real(r8) :: wind_speed0(bounds%begl:bounds%endl) ! Wind speed from atmosphere at start of iteration - real(r8) :: wind_speed_adj(bounds%begl:bounds%endl) ! Adjusted wind speed for iteration - real(r8) :: tau(bounds%begl:bounds%endl) ! Stress used in iteration - real(r8) :: tau_diff(bounds%begl:bounds%endl) ! Difference from previous iteration tau - real(r8) :: prev_tau(bounds%begl:bounds%endl) ! Previous iteration tau + real(r8) :: wind_speed0(1:num_urbanl) ! Wind speed from atmosphere at start of iteration + real(r8) :: wind_speed_adj(1:num_urbanl) ! Adjusted wind speed for iteration + real(r8) :: tau(1:num_urbanl) ! Stress used in iteration + real(r8) :: tau_diff(1:num_urbanl) ! Difference from previous iteration tau + real(r8) :: prev_tau(1:num_urbanl) ! Previous iteration tau real(r8) :: prev_tau_diff(bounds%begl:bounds%endl) ! Previous difference in iteration tau + real(r8), parameter :: beta = 1._r8 ! coefficient of convective velocity + real(r8), parameter :: zii = 1000._r8 ! convective boundary layer height (m) + integer :: lnd_to_urban_filter(bounds%begl:bounds%endl) ! + integer :: col_to_urban_filter(bounds%begc:bounds%endc) + logical :: converged_landunits(bounds%begl:bounds%endl) + integer :: begl, endl, begc, endc, begp, endp + integer :: erridx1, erridx2 + real(r8) :: sum_denom, sum_numer !----------------------------------------------------------------------- - associate( & - snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers - ctype => col_pp%itype , & ! Input: [integer (:) ] column type - z_0_town => lun_pp%z_0_town , & ! Input: [real(r8) (:) ] momentum roughness length of urban landunit (m) - z_d_town => lun_pp%z_d_town , & ! Input: [real(r8) (:) ] displacement height of urban landunit (m) - ht_roof => lun_pp%ht_roof , & ! Input: [real(r8) (:) ] height of urban roof (m) - wtlunit_roof => lun_pp%wtlunit_roof , & ! Input: [real(r8) (:) ] weight of roof with respect to landunit - canyon_hwr => lun_pp%canyon_hwr , & ! Input: [real(r8) (:) ] ratio of building height to street width - wtroad_perv => lun_pp%wtroad_perv , & ! Input: [real(r8) (:) ] weight of pervious road wrt total road - - forc_t => top_as%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (K) - forc_th => top_as%thbot , & ! Input: [real(r8) (:) ] atmospheric potential temperature (K) - forc_rho => top_as%rhobot , & ! Input: [real(r8) (:) ] air density (kg/m**3) - forc_q => top_as%qbot , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) - forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) - forc_u => top_as%ubot , & ! Input: [real(r8) (:) ] atmospheric wind speed in east direction (m/s) - forc_v => top_as%vbot , & ! Input: [real(r8) (:) ] atmospheric wind speed in north direction (m/s) + associate( & + snl => col_pp%snl , & ! Input: [integer (:) ] number of snow layers + ctype => col_pp%itype , & ! Input: [integer (:) ] column type + z_0_town => lun_pp%z_0_town , & ! Input: [real(r8) (:) ] momentum roughness length of urban landunit (m) + z_d_town => lun_pp%z_d_town , & ! Input: [real(r8) (:) ] displacement height of urban landunit (m) + ht_roof => lun_pp%ht_roof , & ! Input: [real(r8) (:) ] height of urban roof (m) + wtlunit_roof => lun_pp%wtlunit_roof , & ! Input: [real(r8) (:) ] weight of roof with respect to landunit + canyon_hwr => lun_pp%canyon_hwr , & ! Input: [real(r8) (:) ] ratio of building height to street width + wtroad_perv => lun_pp%wtroad_perv , & ! Input: [real(r8) (:) ] weight of pervious road wrt total road + + forc_t => top_as%tbot , & ! Input: [real(r8) (:) ] atmospheric temperature (K) + forc_th => top_as%thbot , & ! Input: [real(r8) (:) ] atmospheric potential temperature (K) + forc_rho => top_as%rhobot , & ! Input: [real(r8) (:) ] air density (kg/m**3) + forc_q => top_as%qbot , & ! Input: [real(r8) (:) ] atmospheric specific humidity (kg/kg) + forc_pbot => top_as%pbot , & ! Input: [real(r8) (:) ] atmospheric pressure (Pa) + forc_u => top_as%ubot , & ! Input: [real(r8) (:) ] atmospheric wind speed in east direction (m/s) + forc_v => top_as%vbot , & ! Input: [real(r8) (:) ] atmospheric wind speed in north direction (m/s) wsresp => top_as%wsresp , & ! Input: [real(r8) (:) ] response of wind to surface stress (m/s/Pa) tau_est => top_as%tau_est , & ! Input: [real(r8) (:) ] approximate atmosphere change to zonal wind (m/s) ugust => top_as%ugust , & ! Input: [real(r8) (:) ] gustiness from atmosphere (m/s) @@ -280,235 +279,329 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, qflx_evap_soi => veg_wf%qflx_evap_soi , & ! Output: [real(r8) (:) ] soil evaporation (mm H2O/s) (+ = to atm) qflx_tran_veg => veg_wf%qflx_tran_veg , & ! Output: [real(r8) (:) ] vegetation transpiration (mm H2O/s) (+ = to atm) qflx_evap_veg => veg_wf%qflx_evap_veg , & ! Output: [real(r8) (:) ] vegetation evaporation (mm H2O/s) (+ = to atm) - qflx_evap_tot => veg_wf%qflx_evap_tot , & ! Output: [real(r8) (:) ] qflx_evap_soi + qflx_evap_can + qflx_tran_veg + qflx_evap_tot => veg_wf%qflx_evap_tot & ! Output: [real(r8) (:) ] qflx_evap_soi + qflx_evap_can + qflx_tran_veg - begl => bounds%begl , & - endl => bounds%endl & - ) - - ! Define fields that appear on the restart file for non-urban landunits - do fl = 1,num_nourbanl - l = filter_nourbanl(fl) - taf(l) = spval - qaf(l) = spval - end do + ) + !$acc enter data create(& + !$acc canyontop_wind(:), & + !$acc canyon_u_wind(:), & + !$acc canyon_wind(:), & + !$acc canyon_resistance(:), & + !$acc ur(:), & + !$acc ustar(:), & + !$acc ramu(:), & + !$acc rahu(:), & + !$acc rawu(:), & + !$acc temp1(:), & + !$acc temp12m(:), & + !$acc temp2(:), & + !$acc temp22m(:), & + !$acc thm_g(:), & + !$acc thv_g(:), & + !$acc dth(:), & + !$acc dqh(:), & + !$acc zldis(:), & + !$acc um(:), & + !$acc obu(:), & + !$acc taf_numer(:), & + !$acc taf_denom(:), & + !$acc qaf_numer(:), & + !$acc qaf_denom(:), & + !$acc wtas(:), & + !$acc wtaq(:), & + !$acc wts_sum(:), & + !$acc wtq_sum(:), & + !$acc fm(:), & + !$acc wtus(:), & + !$acc wtuq(:), & + !$acc wtus_roof(:), & + !$acc wtuq_roof(:), & + !$acc wtus_road_perv(:), & + !$acc wtuq_road_perv(:), & + !$acc wtus_road_imperv(:), & + !$acc wtuq_road_imperv(:), & + !$acc wtus_sunwall(:), & + !$acc wtuq_sunwall(:), & + !$acc wtus_shadewall(:), & + !$acc wtuq_shadewall(:), & + !$acc wtus_roof_unscl(:), & + !$acc wtuq_roof_unscl(:), & + !$acc wtus_road_perv_unscl(:), & + !$acc wtuq_road_perv_unscl(:), & + !$acc wtus_road_imperv_unscl(:), & + !$acc wtuq_road_imperv_unscl(:), & + !$acc wtus_sunwall_unscl(:), & + !$acc wtuq_sunwall_unscl(:), & + !$acc wtus_shadewall_unscl(:), & + !$acc wtuq_shadewall_unscl(:), & + !$acc t_sunwall_innerl(:), & + !$acc t_shadewall_innerl(:), & + !$acc t_roof_innerl(:), & + !$acc eflx_sh_grnd_scale(:), & + !$acc qflx_evap_soi_scale(:), & + !$acc eflx_wasteheat_roof(:), & + !$acc eflx_wasteheat_sunwall(:), & + !$acc eflx_wasteheat_shadewall(:), & + !$acc eflx_heat_from_ac_roof(:), & + !$acc eflx_heat_from_ac_sunwall(:), & + !$acc eflx_heat_from_ac_shadewall(:), & + !$acc eflx(:), & + !$acc qflx(:), & + !$acc eflx_scale(:), & + !$acc qflx_scale(:), & + !$acc eflx_err(:), & + !$acc qflx_err(:), & + !$acc local_secp1(:), & + !$acc wind_speed0(:), & + !$acc wind_speed_adj(:), & + !$acc tau(:), & + !$acc tau_diff(:), & + !$acc prev_tau(:), & + !$acc prev_tau_diff(:), & + !$acc lnd_to_urban_filter(:), & + !$acc converged_landunits(:), col_to_urban_filter(:) ) + + + begl = bounds%begl + endl = bounds%endl + begc = bounds%begc + endc = bounds%endc + begp = bounds%begp + endp = bounds%endp ! Get time step - nstep = nstep_mod - dtime = dtime_mod - year = year_curr - month = mon_curr - day = day_curr - secs = secs_curr - - ! Set constants (same as in Biogeophysics1Mod) - beta(begl:endl) = 1._r8 ! Should be set to the same values as in Biogeophysics1Mod - zii(begl:endl) = 1000._r8 ! Should be set to the same values as in Biogeophysics1Mod - + lnd_to_urban_filter(:) = -9999 ! Compute canyontop wind using Masson (2000) - + erridx1 = -9999 + erridx2 = -9999 + !$acc parallel loop independent gang vector default(present) copy(erridx1,erridx2) & + !$acc present(lnd_to_urban_filter(:), ht_roof(:), z_d_town(:),z_0_town(:)) do fl = 1, num_urbanl l = filter_urbanl(fl) + lnd_to_urban_filter(l) = fl g = lun_pp%gridcell(l) t = lun_pp%topounit(l) - local_secp1(l) = secs + nint((grc_pp%londeg(g)/degpsec)/dtime)*dtime - local_secp1(l) = mod(local_secp1(l),isecspday) + local_secp1(fl) = secs_curr + nint((grc_pp%londeg(g)/degpsec)/dtime_mod)*dtime_mod + local_secp1(fl) = mod(local_secp1(fl),isecspday) ! Error checks -#ifndef _OPENACC if (ht_roof(l) - z_d_town(l) <= z_0_town(l)) then - write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' - write (iulog,*) 'h_r - z_d <= z_0' - write (iulog,*) 'ht_roof, z_d_town, z_0_town: ', ht_roof(l), z_d_town(l), & - z_0_town(l) - write (iulog,*) 'elm model is stopping' - call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + erridx1 = l + end if if (forc_hgt_u_patch(lun_pp%pfti(l)) - z_d_town(l) <= z_0_town(l)) then - write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' - write (iulog,*) 'h_u - z_d <= z_0' - write (iulog,*) 'forc_hgt_u_patch, z_d_town, z_0_town: ', forc_hgt_u_patch(lun_pp%pfti(l)), z_d_town(l), & - z_0_town(l) - write (iulog,*) 'elm model is stopping' - call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + erridx2 = l end if -#endif + ! Initialize winds for iteration. if (implicit_stress) then - wind_speed0(l) = max(0.01_r8, hypot(forc_u(t), forc_v(t))) - wind_speed_adj(l) = wind_speed0(l) - ur(l) = max(1.0_r8, sqrt(wind_speed_adj(l)**2 + ugust(t)**2)) + wind_speed0(fl) = max(0.01_r8, hypot(forc_u(t), forc_v(t))) + wind_speed_adj(fl) = wind_speed0(fl) + ur(fl) = max(1.0_r8, wind_speed_adj(fl) + ugust(t)) - prev_tau(l) = tau_est(t) + prev_tau(fl) = tau_est(t) else - ur(l) = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t)+ugust(t)*ugust(t))) + ur(fl) = max(1.0_r8,sqrt(forc_u(t)*forc_u(t)+forc_v(t)*forc_v(t)) + ugust(t)) end if - tau_diff(l) = 1.e100_r8 + tau_diff(fl) = 1.e100_r8 ugust_total(l) = ugust(t) end do + if(erridx1 > 0) then + l = erridx1 + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_r - z_d <= z_0' + write (iulog,*) 'ht_roof, z_d_town, z_0_town: ', ht_roof(l), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'elm model is stopping' + + call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + end if + + if(erridx2 > 0) then + l = erridx2 + write (iulog,*) 'aerodynamic parameter error in UrbanFluxes' + write (iulog,*) 'h_u - z_d <= z_0' + write (iulog,*) 'forc_hgt_u_patch, z_d_town, z_0_town: ', forc_hgt_u_patch(lun_pp%pfti(l)), z_d_town(l), & + z_0_town(l) + write (iulog,*) 'elm model is stopping' + call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + end if + ! Compute fluxes - Follows elm approach for bare soils (Oleson et al 2004) + !$acc parallel loop independent gang vector default(present) & + !$acc present(z_0_town(:),z_d_town(:),taf(:),qaf(:) ) do fl = 1, num_urbanl l = filter_urbanl(fl) t = lun_pp%topounit(l) g = lun_pp%gridcell(l) - thm_g(l) = forc_t(t) + lapse_rate*forc_hgt_t_patch(lun_pp%pfti(l)) - thv_g(l) = forc_th(t)*(1._r8+0.61_r8*forc_q(t)) - dth(l) = thm_g(l)-taf(l) - dqh(l) = forc_q(t)-qaf(l) - dthv = dth(l)*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh(l) - zldis(l) = forc_hgt_u_patch(lun_pp%pfti(l)) - z_d_town(l) - - ! Initialize Obukhov length scale and wind speed including convective velocity - - call MoninObukIni(ur(l), thv_g(l), dthv, zldis(l), z_0_town(l), um(l), obu(l)) + thm_g(fl) = forc_t(t) + lapse_rate*forc_hgt_t_patch(lun_pp%pfti(l)) + thv_g(fl) = forc_th(t)*(1._r8+0.61_r8*forc_q(t)) + dth(fl) = thm_g(fl)-taf(l) + dqh(fl) = forc_q(t)-qaf(l) + dthv = dth(fl)*(1._r8+0.61_r8*forc_q(t))+0.61_r8*forc_th(t)*dqh(fl) + zldis(fl) = forc_hgt_u_patch(lun_pp%pfti(l)) - z_d_town(l) + ! Initialize Monin-Obukhov length and wind speed including convective velocity + call MoninObukIni(ur(fl), thv_g(fl), dthv, zldis(fl), z_0_town(l), um(fl), obu(fl)) end do - ! Initialize conductances - wtus_roof(begl:endl) = 0._r8 - wtus_road_perv(begl:endl) = 0._r8 - wtus_road_imperv(begl:endl) = 0._r8 - wtus_sunwall(begl:endl) = 0._r8 - wtus_shadewall(begl:endl) = 0._r8 - wtuq_roof(begl:endl) = 0._r8 - wtuq_road_perv(begl:endl) = 0._r8 - wtuq_road_imperv(begl:endl) = 0._r8 - wtuq_sunwall(begl:endl) = 0._r8 - wtuq_shadewall(begl:endl) = 0._r8 - wtus_roof_unscl(begl:endl) = 0._r8 - wtus_road_perv_unscl(begl:endl) = 0._r8 - wtus_road_imperv_unscl(begl:endl) = 0._r8 - wtus_sunwall_unscl(begl:endl) = 0._r8 - wtus_shadewall_unscl(begl:endl) = 0._r8 - wtuq_roof_unscl(begl:endl) = 0._r8 - wtuq_road_perv_unscl(begl:endl) = 0._r8 - wtuq_road_imperv_unscl(begl:endl) = 0._r8 - wtuq_sunwall_unscl(begl:endl) = 0._r8 - wtuq_shadewall_unscl(begl:endl) = 0._r8 + ! ! Initialize conductances + !$acc parallel loop independent gang vector default(present) + do fl=1,num_urbanl + wtus_roof(fl) = 0._r8 + wtus_road_perv(fl) = 0._r8 + wtus_road_imperv(fl) = 0._r8 + wtus_sunwall(fl) = 0._r8 + wtus_shadewall(fl) = 0._r8 + wtuq_roof(fl) = 0._r8 + wtuq_road_perv(fl) = 0._r8 + wtuq_road_imperv(fl) = 0._r8 + wtuq_sunwall(fl) = 0._r8 + wtuq_shadewall(fl) = 0._r8 + wtus_roof_unscl(fl) = 0._r8 + wtus_road_perv_unscl(fl) = 0._r8 + wtus_road_imperv_unscl(fl) = 0._r8 + wtus_sunwall_unscl(fl) = 0._r8 + wtus_shadewall_unscl(fl) = 0._r8 + wtuq_roof_unscl(fl) = 0._r8 + wtuq_road_perv_unscl(fl) = 0._r8 + wtuq_road_imperv_unscl(fl) = 0._r8 + wtuq_sunwall_unscl(fl) = 0._r8 + wtuq_shadewall_unscl(fl) = 0._r8 + end do ! Start stability iteration - fnl_iter = num_urbanl - fnc_iter = num_urbanc - filterl_copy(1:num_urbanl) = filter_urbanl(1:num_urbanl) - filterc_copy(1:num_urbanc) = filter_urbanc(1:num_urbanc) + num_copyl = num_urbanl + num_copyc = num_urbanc if (implicit_stress) then loopmax = itmax else loopmax = itmin end if - + ! converged_cols(begc:endc) = .false. + converged_landunits(begl:endl) = .false. + !$acc update device(converged_landunits(:)) ITERATION: do iter = 1, loopmax - ! Get friction velocity, relation for potential ! temperature and humidity profiles of surface boundary layer. - - if (fnl_iter > 0) then - call FrictionVelocity(begl, endl, & + call FrictionVelocity_loops(begl, endl, & num_urbanl, filter_urbanl, & z_d_town(begl:endl), z_0_town(begl:endl), z_0_town(begl:endl), z_0_town(begl:endl), & - obu(begl:endl), iter, ur(begl:endl), um(begl:endl), ugust_total(begl:endl), ustar(begl:endl), & - temp1(begl:endl), temp2(begl:endl), temp12m(begl:endl), temp22m(begl:endl), fm(begl:endl), & - frictionvel_vars, landunit_index=.true.) - end if - - do fl = 1, fnl_iter - l = filterl_copy(fl) + obu(1:num_urbanl), iter, ur(1:num_urbanl), um(1:num_urbanl), ustar(1:num_urbanl), & + temp1(1:num_urbanl), temp2(1:num_urbanl), temp12m(1:num_urbanl), & + temp22m(1:num_urbanl), fm(1:num_urbanl), & + frictionvel_vars, converged_landunits(begl:endl),landunit_index=.true.) + + !$acc parallel loop independent gang vector default(present) & + !$acc present(ht_roof(:),wind_hgt_canyon(:),z_0_town(:),& + !$acc z_d_town(:),canyon_hwr(:),converged_landunits(:)) + do fl = 1, num_urbanl + l = filter_urbanl(fl) t = lun_pp%topounit(l) g = lun_pp%gridcell(l) + if(converged_landunits(l)) cycle ! Determine aerodynamic resistance to fluxes from urban canopy air to ! atmosphere - ramu(l) = 1._r8/(ustar(l)*ustar(l)/um(l)) - rahu(l) = 1._r8/(temp1(l)*ustar(l)) - rawu(l) = 1._r8/(temp2(l)*ustar(l)) + ramu(fl) = 1._r8/(ustar(fl)*ustar(fl)/um(fl)) + rahu(fl) = 1._r8/(temp1(fl)*ustar(fl)) + rawu(fl) = 1._r8/(temp2(fl)*ustar(fl)) ! Calculate magnitude of stress and update wind speed. + #ifndef _OPENACC if (implicit_stress) then - tau(l) = forc_rho(t)*wind_speed_adj(l)/ramu(l) + tau(fl) = forc_rho(t)*wind_speed_adj(fl)/ramu(fl) call shr_flux_update_stress(wind_speed0(l), wsresp(t), tau_est(t), & tau(l), prev_tau(l), tau_diff(l), prev_tau_diff(l), & wind_speed_adj(l)) - ur(l) = max(1.0_r8, sqrt(wind_speed_adj(l)**2 + ugust(t)**2)) + ur(fl) = max(1.0_r8, wind_speed_adj(fl) + ugust(t)) end if + #endif ! Canyon top wind ! If the wind does not change in this loop (explicit stress), then ! we only need to calculate this on the first iteration. if (implicit_stress .or. iter == 1) then - canyontop_wind(l) = ur(l) * & + canyontop_wind(fl) = ur(fl) * & log( (ht_roof(l)-z_d_town(l)) / z_0_town(l) ) / & log( (forc_hgt_u_patch(lun_pp%pfti(l))-z_d_town(l)) / z_0_town(l) ) - ! U component of canyon wind + ! U component of canyon wind if (canyon_hwr(l) < 0.5_r8) then ! isolated roughness flow - canyon_u_wind(l) = canyontop_wind(l) * exp( -0.5_r8*canyon_hwr(l)* & + canyon_u_wind(fl) = canyontop_wind(fl) * exp( -0.5_r8*canyon_hwr(l)* & (1._r8-(wind_hgt_canyon(l)/ht_roof(l))) ) else if (canyon_hwr(l) < 1.0_r8) then ! wake interference flow - canyon_u_wind(l) = canyontop_wind(l) * (1._r8+2._r8*(2._r8/rpi - 1._r8)* & + canyon_u_wind(fl) = canyontop_wind(fl) * (1._r8+2._r8*(2._r8/rpi - 1._r8)* & (ht_roof(l)/(ht_roof(l)/canyon_hwr(l)) - 0.5_r8)) * & exp(-0.5_r8*canyon_hwr(l)*(1._r8-(wind_hgt_canyon(l)/ht_roof(l)))) else ! skimming flow - canyon_u_wind(l) = canyontop_wind(l) * (2._r8/rpi) * & + canyon_u_wind(fl) = canyontop_wind(fl) * (2._r8/rpi) * & exp(-0.5_r8*canyon_hwr(l)*(1._r8-(wind_hgt_canyon(l)/ht_roof(l)))) end if end if ! Determine magnitude of canyon wind by using horizontal wind determined ! previously and vertical wind from friction velocity (Masson 2000) - - canyon_wind(l) = sqrt(canyon_u_wind(l)**2._r8 + ustar(l)**2._r8) + canyon_wind(fl) = sqrt(canyon_u_wind(fl)**2._r8 + ustar(fl)**2._r8) ! Determine canyon_resistance (currently this single resistance determines the ! resistance from urban surfaces (roof, pervious and impervious road, sunlit and ! shaded walls) to urban canopy air, since it is only dependent on wind speed ! Also from Masson 2000. - canyon_resistance(l) = cpair * forc_rho(t) / (11.8_r8 + 4.2_r8*canyon_wind(l)) + canyon_resistance(fl) = cpair * forc_rho(t) / (11.8_r8 + 4.2_r8*canyon_wind(fl)) end do ! This is the first term in the equation solutions for urban canopy air temperature ! and specific humidity (numerator) and is a landunit quantity - do fl = 1, fnl_iter - l = filterl_copy(fl) + !$acc parallel loop independent gang vector default(present) present(converged_landunits(:)) + do fl = 1, num_urbanl + l = filter_urbanl(fl) t = lun_pp%topounit(l) g = lun_pp%gridcell(l) + if(converged_landunits(l)) cycle - taf_numer(l) = thm_g(l)/rahu(l) - taf_denom(l) = 1._r8/rahu(l) - qaf_numer(l) = forc_q(t)/rawu(l) - qaf_denom(l) = 1._r8/rawu(l) + taf_numer(fl) = thm_g(fl)/rahu(fl) + taf_denom(fl) = 1._r8/rahu(fl) + qaf_numer(fl) = forc_q(t)/rawu(fl) + qaf_denom(fl) = 1._r8/rawu(fl) ! First term needed for derivative of heat fluxes - wtas(l) = 1._r8/rahu(l) - wtaq(l) = 1._r8/rawu(l) + wtas(fl) = 1._r8/rahu(fl) + wtaq(fl) = 1._r8/rawu(fl) end do ! Gather other terms for other urban columns for numerator and denominator of ! equations for urban canopy air temperature and specific humidity - - do fc = 1, fnc_iter - c = filterc_copy(fc) + !$acc parallel loop independent gang vector default(present) present(& + !$acc wtroad_perv(:),qaf(:),lnd_to_urban_filter(:),converged_landunits(:),& + !$acc canyon_hwr(:),wtlunit_roof(:)) + do fc = 1, num_urbanc + c = filter_urbanc(fc) l = col_pp%landunit(c) + if(converged_landunits(l)) cycle + fl = lnd_to_urban_filter(l) + col_to_urban_filter(c) = fc if (ctype(c) == icol_roof) then ! scaled sensible heat conductance - wtus(c) = wtlunit_roof(l)/canyon_resistance(l) - wtus_roof(l) = wtus(c) + wtus(fc) = wtlunit_roof(l)/canyon_resistance(fl) + wtus_roof(fl) = wtus(fc) ! unscaled sensible heat conductance - wtus_roof_unscl(l) = 1._r8/canyon_resistance(l) + wtus_roof_unscl(fl) = 1._r8/canyon_resistance(fl) if (snow_depth(c) > 0._r8) then fwet_roof = min(snow_depth(c)/0.05_r8, 1._r8) @@ -520,55 +613,55 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, fwet_roof = 1._r8 end if ! scaled latent heat conductance - wtuq(c) = fwet_roof*(wtlunit_roof(l)/canyon_resistance(l)) - wtuq_roof(l) = wtuq(c) + wtuq(fc) = fwet_roof*(wtlunit_roof(l)/canyon_resistance(fl)) + wtuq_roof(fl) = wtuq(fc) ! unscaled latent heat conductance - wtuq_roof_unscl(l) = fwet_roof*(1._r8/canyon_resistance(l)) + wtuq_roof_unscl(fl) = fwet_roof*(1._r8/canyon_resistance(fl)) ! wasteheat from heating/cooling - if (trim(urban_hac) == urban_wasteheat_on) then - eflx_wasteheat_roof(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + if (urban_hac_int == urban_wasteheat_int) then + eflx_wasteheat_roof(fl) = ac_wasteheat_factor * eflx_urban_ac(c) + & ht_wasteheat_factor * eflx_urban_heat(c) else - eflx_wasteheat_roof(l) = 0._r8 + eflx_wasteheat_roof(fl) = 0._r8 end if ! If air conditioning on, always replace heat removed with heat into canyon - if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then - eflx_heat_from_ac_roof(l) = abs(eflx_urban_ac(c)) + if (urban_hac_int == urban_hac_on_int .or. urban_hac_int == urban_wasteheat_int) then + eflx_heat_from_ac_roof(fl) = abs(eflx_urban_ac(c)) else - eflx_heat_from_ac_roof(l) = 0._r8 + eflx_heat_from_ac_roof(fl) = 0._r8 end if else if (ctype(c) == icol_road_perv) then ! scaled sensible heat conductance - wtus(c) = wtroad_perv(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtus_road_perv(l) = wtus(c) + wtus(fc) = wtroad_perv(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtus_road_perv(fl) = wtus(fc) ! unscaled sensible heat conductance - wtus_road_perv_unscl(l) = 1._r8/canyon_resistance(l) + wtus_road_perv_unscl(fl) = 1._r8/canyon_resistance(fl) ! scaled latent heat conductance - wtuq(c) = wtroad_perv(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtuq_road_perv(l) = wtuq(c) + wtuq(fc) = wtroad_perv(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtuq_road_perv(fl) = wtuq(fc) ! unscaled latent heat conductance - wtuq_road_perv_unscl(l) = 1._r8/canyon_resistance(l) + wtuq_road_perv_unscl(fl) = 1._r8/canyon_resistance(fl) if (use_vsfm) then if (qaf(l) < qg(c)) then if (do_soilevap_beta()) then - wtuq_road_perv(l) = soilbeta(c)*wtuq_road_perv(l) - wtuq_road_perv_unscl(l) = soilbeta(c)*wtuq_road_perv_unscl(l) + wtuq_road_perv(fl) = soilbeta(c)*wtuq_road_perv(fl) + wtuq_road_perv_unscl(fl) = soilbeta(c)*wtuq_road_perv_unscl(fl) endif endif endif else if (ctype(c) == icol_road_imperv) then ! scaled sensible heat conductance - wtus(c) = (1._r8-wtroad_perv(l))*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtus_road_imperv(l) = wtus(c) + wtus(fc) = (1._r8-wtroad_perv(l))*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtus_road_imperv(fl) = wtus(fc) ! unscaled sensible heat conductance - wtus_road_imperv_unscl(l) = 1._r8/canyon_resistance(l) + wtus_road_imperv_unscl(fl) = 1._r8/canyon_resistance(fl) if (snow_depth(c) > 0._r8) then fwet_road_imperv = min(snow_depth(c)/0.05_r8, 1._r8) @@ -580,179 +673,206 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, fwet_road_imperv = 1._r8 end if ! scaled latent heat conductance - wtuq(c) = fwet_road_imperv*(1._r8-wtroad_perv(l))*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtuq_road_imperv(l) = wtuq(c) + wtuq(fc) = fwet_road_imperv*(1._r8-wtroad_perv(l))*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtuq_road_imperv(fl) = wtuq(fc) ! unscaled latent heat conductance - wtuq_road_imperv_unscl(l) = fwet_road_imperv*(1._r8/canyon_resistance(l)) + wtuq_road_imperv_unscl(fl) = fwet_road_imperv*(1._r8/canyon_resistance(fl)) else if (ctype(c) == icol_sunwall) then ! scaled sensible heat conductance - wtus(c) = canyon_hwr(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtus_sunwall(l) = wtus(c) + wtus(fc) = canyon_hwr(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtus_sunwall(fl) = wtus(fc) ! unscaled sensible heat conductance - wtus_sunwall_unscl(l) = 1._r8/canyon_resistance(l) + wtus_sunwall_unscl(fl) = 1._r8/canyon_resistance(fl) ! scaled latent heat conductance - wtuq(c) = 0._r8 - wtuq_sunwall(l) = wtuq(c) + wtuq(fc) = 0._r8 + wtuq_sunwall(fl) = wtuq(fc) ! unscaled latent heat conductance - wtuq_sunwall_unscl(l) = 0._r8 + wtuq_sunwall_unscl(fl) = 0._r8 ! wasteheat from heating/cooling - if (trim(urban_hac) == urban_wasteheat_on) then - eflx_wasteheat_sunwall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + if (urban_hac_int == urban_wasteheat_int) then + eflx_wasteheat_sunwall(fl) = ac_wasteheat_factor * eflx_urban_ac(c) + & ht_wasteheat_factor * eflx_urban_heat(c) else - eflx_wasteheat_sunwall(l) = 0._r8 + eflx_wasteheat_sunwall(fl) = 0._r8 end if ! If air conditioning on, always replace heat removed with heat into canyon - if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then - eflx_heat_from_ac_sunwall(l) = abs(eflx_urban_ac(c)) + if (urban_hac_int == urban_hac_on_int .or. urban_hac_int == urban_wasteheat_int) then + eflx_heat_from_ac_sunwall(fl) = abs(eflx_urban_ac(c)) else - eflx_heat_from_ac_sunwall(l) = 0._r8 + eflx_heat_from_ac_sunwall(fl) = 0._r8 end if else if (ctype(c) == icol_shadewall) then ! scaled sensible heat conductance - wtus(c) = canyon_hwr(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(l) - wtus_shadewall(l) = wtus(c) + wtus(fc) = canyon_hwr(l)*(1._r8-wtlunit_roof(l))/canyon_resistance(fl) + wtus_shadewall(fl) = wtus(fc) ! unscaled sensible heat conductance - wtus_shadewall_unscl(l) = 1._r8/canyon_resistance(l) + wtus_shadewall_unscl(fl) = 1._r8/canyon_resistance(fl) ! scaled latent heat conductance - wtuq(c) = 0._r8 - wtuq_shadewall(l) = wtuq(c) + wtuq(fc) = 0._r8 + wtuq_shadewall(fl) = wtuq(fc) ! unscaled latent heat conductance - wtuq_shadewall_unscl(l) = 0._r8 + wtuq_shadewall_unscl(fl) = 0._r8 ! wasteheat from heating/cooling - if (trim(urban_hac) == urban_wasteheat_on) then - eflx_wasteheat_shadewall(l) = ac_wasteheat_factor * eflx_urban_ac(c) + & + if (urban_hac_int == urban_wasteheat_int) then + eflx_wasteheat_shadewall(fl) = ac_wasteheat_factor * eflx_urban_ac(c) + & ht_wasteheat_factor * eflx_urban_heat(c) else - eflx_wasteheat_shadewall(l) = 0._r8 + eflx_wasteheat_shadewall(fl) = 0._r8 end if ! If air conditioning on, always replace heat removed with heat into canyon - if (trim(urban_hac) == urban_hac_on .or. trim(urban_hac) == urban_wasteheat_on) then - eflx_heat_from_ac_shadewall(l) = abs(eflx_urban_ac(c)) + if (urban_hac_int == urban_hac_on_int .or. urban_hac_int == urban_wasteheat_int) then + eflx_heat_from_ac_shadewall(fl) = abs(eflx_urban_ac(c)) else - eflx_heat_from_ac_shadewall(l) = 0._r8 + eflx_heat_from_ac_shadewall(fl) = 0._r8 end if - else -#ifndef _OPENACC - write(iulog,*) 'c, ctype, pi = ', c, ctype(c), pi - write(iulog,*) 'Column indices for: shadewall, sunwall, road_imperv, road_perv, roof: ' - write(iulog,*) icol_shadewall, icol_sunwall, icol_road_imperv, icol_road_perv, icol_roof - call endrun(decomp_index=l, elmlevel=namel, msg="ERROR, ctype out of range"//errmsg(__FILE__, __LINE__)) -#endif + ! else + ! write(iulog,*) 'c, ctype, pi = ', c, ctype(c), pi + ! write(iulog,*) 'Column indices for: shadewall, sunwall, road_imperv, road_perv, roof: ' + ! write(iulog,*) icol_shadewall, icol_sunwall, icol_road_imperv, icol_road_perv, icol_roof + !call endrun(decomp_index=l, elmlevel=namel, msg="ERROR, ctype out of range"//errmsg(__FILE__, __LINE__)) end if + ! Made seperate reduction loop + ! taf_numer(fl) = taf_numer(fl) + t_grnd(c)*wtus(fc) + ! taf_denom(fl) = taf_denom(fl) + wtus(fc) + ! qaf_numer(fl) = qaf_numer(fl) + qg(c)*wtuq(fc) + ! qaf_denom(fl) = qaf_denom(fl) + wtuq(fc) - taf_numer(l) = taf_numer(l) + t_grnd(c)*wtus(c) - taf_denom(l) = taf_denom(l) + wtus(c) - qaf_numer(l) = qaf_numer(l) + qg(c)*wtuq(c) - qaf_denom(l) = qaf_denom(l) + wtuq(c) - end do + !$acc parallel loop independent gang worker default(present) private(sum_denom,sum_numer)& + !$acc present(converged_landunits(:)) + do fl = 1, num_urbanl + sum_denom = taf_denom(fl) + sum_numer = taf_numer(fl) + l = filter_urbanl(fl) + if(converged_landunits(l)) cycle + !$acc loop vector reduction(+:sum_denom,sum_numer) + do c = lun_pp%coli(l), lun_pp%colf(l) + if(col_pp%active(c)) then + fc = col_to_urban_filter(c) + sum_denom = sum_denom + wtus(fc) + sum_numer = sum_numer + t_grnd(c)*wtus(fc) + end if + end do + taf_denom(fl) = sum_denom + taf_numer(fl) = sum_numer + end do + !$acc parallel loop independent gang worker default(present) private(sum_denom,sum_numer)& + !$acc present(qg(:),col_pp%active(:),lun_pp%coli(:),lun_pp%colf(:),col_to_urban_filter(:)) + do fl = 1, num_urbanl + sum_denom = qaf_denom(fl) + sum_numer = qaf_numer(fl) + l = filter_urbanl(fl) + !$acc loop vector reduction(+:sum_denom,sum_numer) + do c = lun_pp%coli(l), lun_pp%colf(l) + if(col_pp%active(c)) then + fc = col_to_urban_filter(c) + sum_denom = sum_denom + wtuq(fc) + sum_numer = sum_numer + qg(c)*wtuq(fc) + end if + end do + qaf_denom(fl) = sum_denom + qaf_numer(fl) = sum_numer + end do ! Calculate new urban canopy air temperature and specific humidity - do fl = 1, fnl_iter - l = filterl_copy(fl) + !$acc parallel loop independent gang vector default(present)& + !$acc present(wtroad_perv(:),taf(:),converged_landunits(:),eflx_heat_from_ac(:),& + !$acc eflx_traffic_factor(:),eflx_wasteheat(:),eflx_traffic(:),qaf(:), & + !$acc wtlunit_roof(:),canyon_hwr(:) ) + do fl = 1, num_urbanl + l = filter_urbanl(fl) g = lun_pp%gridcell(l) - + if(converged_landunits(l)) cycle ! Total waste heat and heat from AC is sum of heat for walls and roofs ! accounting for different surface areas - eflx_wasteheat(l) = wtlunit_roof(l)*eflx_wasteheat_roof(l) + & - (1._r8-wtlunit_roof(l))*(canyon_hwr(l)*(eflx_wasteheat_sunwall(l) + & - eflx_wasteheat_shadewall(l))) + eflx_wasteheat(l) = wtlunit_roof(l)*eflx_wasteheat_roof(fl) + & + (1._r8-wtlunit_roof(l))*(canyon_hwr(l)*(eflx_wasteheat_sunwall(fl) + & + eflx_wasteheat_shadewall(fl))) ! Limit wasteheat to ensure that we don't get any unrealistically strong ! positive feedbacks due to AC in a warmer climate eflx_wasteheat(l) = min(eflx_wasteheat(l),wasteheat_limit) - eflx_heat_from_ac(l) = wtlunit_roof(l)*eflx_heat_from_ac_roof(l) + & - (1._r8-wtlunit_roof(l))*(canyon_hwr(l)*(eflx_heat_from_ac_sunwall(l) + & - eflx_heat_from_ac_shadewall(l))) + eflx_heat_from_ac(l) = wtlunit_roof(l)*eflx_heat_from_ac_roof(fl) + & + (1._r8-wtlunit_roof(l))*(canyon_hwr(l)*(eflx_heat_from_ac_sunwall(fl) + & + eflx_heat_from_ac_shadewall(fl))) ! Calculate traffic heat flux ! Only comes from impervious road eflx_traffic(l) = (1._r8-wtlunit_roof(l))*(1._r8-wtroad_perv(l))* & eflx_traffic_factor(l) - taf(l) = taf_numer(l)/taf_denom(l) - qaf(l) = qaf_numer(l)/qaf_denom(l) + taf(l) = taf_numer(fl)/taf_denom(fl) + qaf(l) = qaf_numer(fl)/qaf_denom(fl) - wts_sum(l) = wtas(l) + wtus_roof(l) + wtus_road_perv(l) + & - wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l) + wts_sum(fl) = wtas(fl) + wtus_roof(fl) + wtus_road_perv(fl) + & + wtus_road_imperv(fl) + wtus_sunwall(fl) + wtus_shadewall(fl) - wtq_sum(l) = wtaq(l) + wtuq_roof(l) + wtuq_road_perv(l) + & - wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l) + wtq_sum(fl) = wtaq(fl) + wtuq_roof(fl) + wtuq_road_perv(fl) + & + wtuq_road_imperv(fl) + wtuq_sunwall(fl) + wtuq_shadewall(fl) end do ! This section of code is not required if niters = 1 ! Determine stability using new taf and qaf - ! TODO: Some of these constants replicate what is in FrictionVelocity and BareGround fluxes should consildate. EBK - do fl = 1, fnl_iter - l = filterl_copy(fl) + ! TODO: Some of these constants replicate what is in FrictionVelocity + ! and BareGround fluxes should consildate. EBK + !$acc parallel loop independent gang vector default(present) & + !$acc present(taf(:), qaf(:), converged_landunits(:) ) + do fl = 1, num_urbanl + l = filter_urbanl(fl) t = lun_pp%topounit(l) g = lun_pp%gridcell(l) + if(converged_landunits(l)) cycle - dth(l) = thm_g(l)-taf(l) - dqh(l) = forc_q(t)-qaf(l) - tstar = temp1(l)*dth(l) - qstar = temp2(l)*dqh(l) - thvstar = tstar*(1._r8+0.61_r8*forc_q(t)) + 0.61_r8*forc_th(t)*qstar - zeta = zldis(l)*vkc*grav*thvstar/(ustar(l)**2*thv_g(l)) + dth(fl) = thm_g(fl)-taf(l) + dqh(fl) = forc_q(t)-qaf(l) + tstar = temp1(fl)*dth(fl) + qstar = temp2(fl)*dqh(fl) + thvstar = tstar*(1._r8+0.61_r8*forc_q(t)) + 0.61_r8*forc_th(t)*qstar + zeta = zldis(fl)*vkc*grav*thvstar/(ustar(fl)**2*thv_g(fl)) + if (zeta >= 0._r8) then !stable zeta = min(2._r8,max(zeta,0.01_r8)) - um(l) = max(ur(l),0.1_r8) + um(fl) = max(ur(fl),0.1_r8) else !unstable zeta = max(-100._r8,min(zeta,-0.01_r8)) - if ((.not. atm_gustiness) .or. force_land_gustiness) then - wc = beta(l)*(-grav*ustar(l)*thvstar*zii(l)/thv_g(l))**0.333_r8 - ugust_total(l) = sqrt(ugust(t)**2 + wc**2) - um(l) = sqrt(ur(l)*ur(l) + wc*wc) - else - um(l) = max(ur(l),0.1_r8) - end if + wc = beta*(-grav*ustar(fl)*thvstar*zii/thv_g(fl))**0.333_r8 + um(fl) = sqrt(ur(fl)*ur(fl) + wc*wc) end if - - obu(l) = zldis(l)/zeta + obu(fl) = zldis(fl)/zeta end do ! Test for convergence iter_final = iter if (iter >= itmin) then - fnl_iter_old = fnl_iter - fnl_iter = 0 - do fl = 1, fnl_iter_old - l = filterl_copy(fl) - if (.not. (abs(tau_diff(l)) < dtaumin)) then - fnl_iter = fnl_iter + 1 - filterl_copy(fnl_iter) = l + num_unconverged = 0 + !$acc parallel loop independent gang vector default(present) & + !$acc present(converged_landunits(:)) copy(num_unconverged) reduction(+:num_unconverged) + do fl = 1, num_urbanl + l = filter_urbanl(fl) + if (.not. (abs(tau_diff(fl)) < dtaumin)) then + num_unconverged = num_unconverged + 1 + else + converged_landunits(l) = .true. end if end do - if (fnl_iter == 0) then + if (num_unconverged == 0) then + print *, "UrbanFluxes::Converged after ",iter,"iterations" exit ITERATION end if - ! After weeding out landunits that have converged, we also need to - ! filter out the associated columns. - fnc_iter_old = fnc_iter - fnc_iter = 0 - do fc = 1, fnc_iter_old - c = filterc_copy(fc) - l = col_pp%landunit(c) - if (.not. (abs(tau_diff(l)) < dtaumin)) then - fnc_iter = fnc_iter + 1 - filterc_copy(fnc_iter) = c - end if - end do end if end do ITERATION ! end iteration @@ -761,9 +881,16 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, ! the following initializations are needed to ensure that the values are 0 over non- ! active urban Patches - eflx_sh_grnd_scale(bounds%begp : bounds%endp) = 0._r8 - qflx_evap_soi_scale(bounds%begp : bounds%endp) = 0._r8 - + ! eflx_sh_grnd_scale(bounds%begp : bounds%endp) = 0._r8 + ! qflx_evap_soi_scale(bounds%begp : bounds%endp) = 0._r8 + + !$acc parallel loop independent gang vector default(present) + do p = begp, endp + eflx_sh_grnd_scale(p) = 0._r8 + qflx_evap_soi_scale(p) = 0._r8 + enddo + !$acc parallel loop independent gang vector default(present) & + !$acc present(qaf(:), taf(:), lnd_to_urban_filter(:)) do f = 1, num_urbanp p = filter_urbanp(f) @@ -771,8 +898,9 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, g = veg_pp%gridcell(p) t = veg_pp%topounit(p) l = veg_pp%landunit(p) - - ram1(p) = ramu(l) !pass value to global variable + fl = lnd_to_urban_filter(l) + fc = col_to_urban_filter(c) + ram1(p) = ramu(fl) !pass value to global variable ! Upward and downward canopy longwave are zero @@ -783,73 +911,73 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, ! ground temperature if (ctype(c) == icol_roof) then - cgrnds(p) = forc_rho(t) * cpair * (wtas(l) + wtus_road_perv(l) + & - wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & - (wtus_roof_unscl(l)/wts_sum(l)) - cgrndl(p) = forc_rho(t) * (wtaq(l) + wtuq_road_perv(l) + & - wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & - (wtuq_roof_unscl(l)/wtq_sum(l))*dqgdT(c) + cgrnds(p) = forc_rho(t) * cpair * (wtas(fl) + wtus_road_perv(fl) + & + wtus_road_imperv(fl) + wtus_sunwall(fl) + wtus_shadewall(fl)) * & + (wtus_roof_unscl(fl)/wts_sum(fl)) + cgrndl(p) = forc_rho(t) * (wtaq(fl) + wtuq_road_perv(fl) + & + wtuq_road_imperv(fl) + wtuq_sunwall(fl) + wtuq_shadewall(fl)) * & + (wtuq_roof_unscl(fl)/wtq_sum(fl))*dqgdT(c) else if (ctype(c) == icol_road_perv) then - cgrnds(p) = forc_rho(t) * cpair * (wtas(l) + wtus_roof(l) + & - wtus_road_imperv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & - (wtus_road_perv_unscl(l)/wts_sum(l)) - cgrndl(p) = forc_rho(t) * (wtaq(l) + wtuq_roof(l) + & - wtuq_road_imperv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & - (wtuq_road_perv_unscl(l)/wtq_sum(l))*dqgdT(c) + cgrnds(p) = forc_rho(t) * cpair * (wtas(fl) + wtus_roof(fl) + & + wtus_road_imperv(fl) + wtus_sunwall(fl) + wtus_shadewall(fl)) * & + (wtus_road_perv_unscl(fl)/wts_sum(fl)) + cgrndl(p) = forc_rho(t) * (wtaq(fl) + wtuq_roof(fl) + & + wtuq_road_imperv(fl) + wtuq_sunwall(fl) + wtuq_shadewall(fl)) * & + (wtuq_road_perv_unscl(fl)/wtq_sum(fl))*dqgdT(c) else if (ctype(c) == icol_road_imperv) then - cgrnds(p) = forc_rho(t) * cpair * (wtas(l) + wtus_roof(l) + & - wtus_road_perv(l) + wtus_sunwall(l) + wtus_shadewall(l)) * & - (wtus_road_imperv_unscl(l)/wts_sum(l)) - cgrndl(p) = forc_rho(t) * (wtaq(l) + wtuq_roof(l) + & - wtuq_road_perv(l) + wtuq_sunwall(l) + wtuq_shadewall(l)) * & - (wtuq_road_imperv_unscl(l)/wtq_sum(l))*dqgdT(c) + cgrnds(p) = forc_rho(t) * cpair * (wtas(fl) + wtus_roof(fl) + & + wtus_road_perv(fl) + wtus_sunwall(fl) + wtus_shadewall(fl)) * & + (wtus_road_imperv_unscl(fl)/wts_sum(fl)) + cgrndl(p) = forc_rho(t) * (wtaq(fl) + wtuq_roof(fl) + & + wtuq_road_perv(fl) + wtuq_sunwall(fl) + wtuq_shadewall(fl)) * & + (wtuq_road_imperv_unscl(fl)/wtq_sum(fl))*dqgdT(c) else if (ctype(c) == icol_sunwall) then - cgrnds(p) = forc_rho(t) * cpair * (wtas(l) + wtus_roof(l) + & - wtus_road_perv(l) + wtus_road_imperv(l) + wtus_shadewall(l)) * & - (wtus_sunwall_unscl(l)/wts_sum(l)) + cgrnds(p) = forc_rho(t) * cpair * (wtas(fl) + wtus_roof(fl) + & + wtus_road_perv(fl) + wtus_road_imperv(fl) + wtus_shadewall(fl)) * & + (wtus_sunwall_unscl(fl)/wts_sum(fl)) cgrndl(p) = 0._r8 else if (ctype(c) == icol_shadewall) then - cgrnds(p) = forc_rho(t) * cpair * (wtas(l) + wtus_roof(l) + & - wtus_road_perv(l) + wtus_road_imperv(l) + wtus_sunwall(l)) * & - (wtus_shadewall_unscl(l)/wts_sum(l)) + cgrnds(p) = forc_rho(t) * cpair * (wtas(fl) + wtus_roof(fl) + & + wtus_road_perv(fl) + wtus_road_imperv(fl) + wtus_sunwall(fl)) * & + (wtus_shadewall_unscl(fl)/wts_sum(fl)) cgrndl(p) = 0._r8 end if cgrnd(p) = cgrnds(p) + cgrndl(p)*htvp(c) ! Surface fluxes of momentum, sensible and latent heat - taux(p) = -forc_rho(t)*forc_u(t)/ramu(l) - tauy(p) = -forc_rho(t)*forc_v(t)/ramu(l) + taux(p) = -forc_rho(t)*forc_u(t)/ramu(fl) + tauy(p) = -forc_rho(t)*forc_v(t)/ramu(fl) if (implicit_stress) then - taux(p) = taux(p) * (wind_speed_adj(l) / wind_speed0(l)) - tauy(p) = tauy(p) * (wind_speed_adj(l) / wind_speed0(l)) + taux(p) = taux(p) * (wind_speed_adj(fl) / wind_speed0(fl)) + tauy(p) = tauy(p) * (wind_speed_adj(fl) / wind_speed0(fl)) end if ! Use new canopy air temperature - dth(l) = taf(l) - t_grnd(c) + dth(fl) = taf(l) - t_grnd(c) if (ctype(c) == icol_roof) then - eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_roof_unscl(l)*dth(l) + eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_roof_unscl(fl)*dth(fl) eflx_sh_snow(p) = 0._r8 eflx_sh_soil(p) = 0._r8 eflx_sh_h2osfc(p)= 0._r8 else if (ctype(c) == icol_road_perv) then - eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_road_perv_unscl(l)*dth(l) + eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_road_perv_unscl(fl)*dth(fl) eflx_sh_snow(p) = 0._r8 eflx_sh_soil(p) = 0._r8 eflx_sh_h2osfc(p)= 0._r8 else if (ctype(c) == icol_road_imperv) then - eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_road_imperv_unscl(l)*dth(l) + eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_road_imperv_unscl(fl)*dth(fl) eflx_sh_snow(p) = 0._r8 eflx_sh_soil(p) = 0._r8 eflx_sh_h2osfc(p)= 0._r8 else if (ctype(c) == icol_sunwall) then - eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_sunwall_unscl(l)*dth(l) + eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_sunwall_unscl(fl)*dth(fl) eflx_sh_snow(p) = 0._r8 eflx_sh_soil(p) = 0._r8 eflx_sh_h2osfc(p)= 0._r8 else if (ctype(c) == icol_shadewall) then - eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_shadewall_unscl(l)*dth(l) + eflx_sh_grnd(p) = -forc_rho(t)*cpair*wtus_shadewall_unscl(fl)*dth(fl) eflx_sh_snow(p) = 0._r8 eflx_sh_soil(p) = 0._r8 eflx_sh_h2osfc(p)= 0._r8 @@ -858,24 +986,24 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, eflx_sh_tot(p) = eflx_sh_grnd(p) eflx_sh_tot_u(p) = eflx_sh_tot(p) - dqh(l) = qaf(l) - qg(c) + dqh(fl) = qaf(l) - qg(c) if (ctype(c) == icol_roof) then - qflx_evap_soi(p) = -forc_rho(t)*wtuq_roof_unscl(l)*dqh(l) + qflx_evap_soi(p) = -forc_rho(t)*wtuq_roof_unscl(fl)*dqh(fl) else if (ctype(c) == icol_road_perv) then ! Evaporation assigned to soil term if dew or snow ! or if no liquid water available in soil column - if (dqh(l) > 0._r8 .or. frac_sno(c) > 0._r8 .or. soilalpha_u(c) <= 0._r8) then - qflx_evap_soi(p) = -forc_rho(t)*wtuq_road_perv_unscl(l)*dqh(l) + if (dqh(fl) > 0._r8 .or. frac_sno(c) > 0._r8 .or. soilalpha_u(c) <= 0._r8) then + qflx_evap_soi(p) = -forc_rho(t)*wtuq_road_perv_unscl(fl)*dqh(fl) qflx_tran_veg(p) = 0._r8 ! Otherwise, evaporation assigned to transpiration term else qflx_evap_soi(p) = 0._r8 - qflx_tran_veg(p) = -forc_rho(t)*wtuq_road_perv_unscl(l)*dqh(l) + qflx_tran_veg(p) = -forc_rho(t)*wtuq_road_perv_unscl(fl)*dqh(fl) end if qflx_evap_veg(p) = qflx_tran_veg(p) else if (ctype(c) == icol_road_imperv) then - qflx_evap_soi(p) = -forc_rho(t)*wtuq_road_imperv_unscl(l)*dqh(l) + qflx_evap_soi(p) = -forc_rho(t)*wtuq_road_imperv_unscl(fl)*dqh(fl) else if (ctype(c) == icol_sunwall) then qflx_evap_soi(p) = 0._r8 else if (ctype(c) == icol_shadewall) then @@ -883,66 +1011,87 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, end if ! SCALED sensible and latent heat flux for error check - eflx_sh_grnd_scale(p) = -forc_rho(t)*cpair*wtus(c)*dth(l) - qflx_evap_soi_scale(p) = -forc_rho(t)*wtuq(c)*dqh(l) + eflx_sh_grnd_scale(p) = -forc_rho(t)*cpair*wtus(fc)*dth(fl) + qflx_evap_soi_scale(p) = -forc_rho(t)*wtuq(fc)*dqh(fl) end do ! Check to see that total sensible and latent heat equal the sum of ! the scaled heat fluxes above + !$acc parallel loop independent gang vector default(present) present(qaf(:), taf(:)) do fl = 1, num_urbanl l = filter_urbanl(fl) t = lun_pp%topounit(l) g = lun_pp%gridcell(l) - eflx(l) = -(forc_rho(t)*cpair/rahu(l))*(thm_g(l) - taf(l)) - qflx(l) = -(forc_rho(t)/rawu(l))*(forc_q(t) - qaf(l)) - eflx_scale(l) = sum(eflx_sh_grnd_scale(lun_pp%pfti(l):lun_pp%pftf(l))) - qflx_scale(l) = sum(qflx_evap_soi_scale(lun_pp%pfti(l):lun_pp%pftf(l))) - eflx_err(l) = eflx_scale(l) - eflx(l) - qflx_err(l) = qflx_scale(l) - qflx(l) + ! + eflx_scale = 0.0_r8 + qflx_scale = 0.0_r8 + eflx = -(forc_rho(t)*cpair/rahu(fl))*(thm_g(fl) - taf(l)) + qflx = -(forc_rho(t)/rawu(fl))*(forc_q(t) - qaf(l)) + !$acc loop vector reduction(+:eflx_scale,qflx_scale) + do p = lun_pp%pfti(l), lun_pp%pftf(l) + if(veg_pp%active(p) .and. lun_pp%urbpoi(l)) then + eflx_scale = eflx_scale + eflx_sh_grnd_scale(p) + qflx_scale = qflx_scale + qflx_evap_soi_scale(p) + end if + end do + eflx_err = eflx_scale - eflx + qflx_err = qflx_scale - qflx + if(abs(eflx_err) > 0.01_r8) then + found=.true. + indexl = l + print *, "EFLX_ERR indexl",l + stop + end if + if (abs(qflx_err) > 4.e-9_r8) then + found = .true. + indexl = l + exit + end if end do found = .false. + !$acc parallel loop independent gang vector default(present) do fl = 1, num_urbanl l = filter_urbanl(fl) - if (abs(eflx_err(l)) > 0.01_r8) then + if (abs(eflx_err(fl)) > 0.01_r8) then found = .true. - indexl = l + indexl = fl exit end if end do -#ifndef _OPENACC if ( found ) then write(iulog,*)'WARNING: Total sensible heat does not equal sum of scaled heat fluxes for urban columns ',& - ' nstep = ',nstep,' indexl= ',indexl,' eflx_err= ',eflx_err(indexl) + ' nstep = ',nstep_mod,' indexl= ',indexl,' eflx_err= ',eflx_err(indexl) if (abs(eflx_err(indexl)) > .01_r8) then + l = filter_urbanl(indexl) write(iulog,*)'elm model is stopping - error is greater than .01 W/m**2' write(iulog,*)'eflx_scale = ',eflx_scale(indexl) - write(iulog,*)'eflx_sh_grnd_scale: ',eflx_sh_grnd_scale(lun_pp%pfti(indexl):lun_pp%pftf(indexl)) + write(iulog,*)'eflx_sh_grnd_scale: ',eflx_sh_grnd_scale(lun_pp%pfti(l):lun_pp%pftf(l)) write(iulog,*)'eflx = ',eflx(indexl) ! test code, PET - write(iulog,*)'tbot = ',forc_t(lun_pp%topounit(indexl)) + write(iulog,*)'tbot = ',forc_t(lun_pp%topounit(l)) call endrun(decomp_index=indexl, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) end if end if -#endif - found = .false. + erridx1 = -9999 + !$acc parallel loop independent gang vector default(present) copy(erridx1) do fl = 1, num_urbanl l = filter_urbanl(fl) ! 4.e-9 kg/m**2/s = 0.01 W/m**2 - if (abs(qflx_err(l)) > 4.e-9_r8) then - found = .true. - indexl = l - exit + if (abs(qflx_err(fl)) > 4.e-9_r8) then + ! found = .true. + erridx1 = l + ! exit end if end do -#ifndef _OPENACC - if ( found ) then + if ( erridx1 > 0 ) then + indexl = erridx1 write(iulog,*)'WARNING: Total water vapor flux does not equal sum of scaled water vapor fluxes for urban columns ',& - ' nstep = ',nstep,' indexl= ',indexl,' qflx_err= ',qflx_err(indexl) + ' nstep = ',nstep_mod,' indexl= ',indexl,' qflx_err= ',qflx_err(indexl) if (abs(qflx_err(indexl)) > 4.e-9_r8) then write(iulog,*)'elm model is stopping - error is greater than 4.e-9 kg/m**2/s' write(iulog,*)'qflx_scale = ',qflx_scale(indexl) @@ -950,18 +1099,17 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, call endrun(decomp_index=indexl, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) end if end if -#endif ! Check for convergence of stress. if (implicit_stress) then do fl = 1, num_urbanl l = filter_urbanl(fl) - if (abs(tau_diff(l)) > dtaumin) then - if (nstep > 0) then ! Suppress common warnings on the first time step. + if (abs(tau_diff(fl)) > dtaumin) then + if (nstep_mod > 0) then ! Suppress common warnings on the first time step. write(iulog,*)'WARNING: Stress did not converge for urban columns ',& ' nstep = ',nstep,' indexl= ',l,' prev_tau_diff= ',prev_tau_diff(l),& - ' tau_diff= ',tau_diff(l),' tau= ',tau(l),& - ' wind_speed_adj= ',wind_speed_adj(l),' iter_final= ',iter_final + ' tau_diff= ',tau_diff(fl),' tau= ',tau(fl),& + ' wind_speed_adj= ',wind_speed_adj(fl),' iter_final= ',iter_final end if end if end do @@ -969,31 +1117,36 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, ! Gather terms required to determine internal building temperature + !$acc parallel loop independent gang vector default(present) present(& + !$acc t_soisno(:,:),lnd_to_urban_filter(:) ) do fc = 1,num_urbanc c = filter_urbanc(fc) l = col_pp%landunit(c) - + fl = lnd_to_urban_filter(l) if (ctype(c) == icol_roof) then - t_roof_innerl(l) = t_soisno(c,nlevurb) + t_roof_innerl(fl) = t_soisno(c,nlevurb) else if (ctype(c) == icol_sunwall) then - t_sunwall_innerl(l) = t_soisno(c,nlevurb) + t_sunwall_innerl(fl) = t_soisno(c,nlevurb) else if (ctype(c) == icol_shadewall) then - t_shadewall_innerl(l) = t_soisno(c,nlevurb) + t_shadewall_innerl(fl) = t_soisno(c,nlevurb) end if end do ! Calculate internal building temperature + !$acc parallel loop independent gang vector default(present) present(& + !$acc ht_roof(:),t_building(:),canyon_hwr(:),wtlunit_roof(:)) do fl = 1, num_urbanl l = filter_urbanl(fl) lngth_roof = (ht_roof(l)/canyon_hwr(l))*wtlunit_roof(l)/(1._r8-wtlunit_roof(l)) - t_building(l) = (ht_roof(l)*(t_shadewall_innerl(l) + t_sunwall_innerl(l)) & - +lngth_roof*t_roof_innerl(l))/(2._r8*ht_roof(l)+lngth_roof) + t_building(l) = (ht_roof(l)*(t_shadewall_innerl(fl) + t_sunwall_innerl(fl)) & + +lngth_roof*t_roof_innerl(fl))/(2._r8*ht_roof(l)+lngth_roof) end do ! No roots for urban except for pervious road + !$acc parallel loop independent gang vector default(present) collapse(2) do j = 1, nlevgrnd do f = 1, num_urbanp p = filter_urbanp(f) @@ -1001,12 +1154,12 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, if (ctype(c) == icol_road_perv) then rootr(p,j) = rootr_road_perv(c,j) else - rootr(p,j) = 0._r8 end if end do end do + !$acc parallel loop independent gang vector default(present) present(taf(:),qaf(:)) do f = 1, num_urbanp p = filter_urbanp(f) @@ -1033,6 +1186,85 @@ subroutine UrbanFluxes (bounds, num_nourbanl, filter_nourbanl, end do + !$acc exit data delete(& + !$acc canyontop_wind(:), & + !$acc canyon_u_wind(:), & + !$acc canyon_wind(:), & + !$acc canyon_resistance(:), & + !$acc ur(:), & + !$acc ustar(:), & + !$acc ramu(:), & + !$acc rahu(:), & + !$acc rawu(:), & + !$acc temp1(:), & + !$acc temp12m(:), & + !$acc temp2(:), & + !$acc temp22m(:), & + !$acc thm_g(:), & + !$acc thv_g(:), & + !$acc dth(:), & + !$acc dqh(:), & + !$acc zldis(:), & + !$acc um(:), & + !$acc obu(:), & + !$acc taf_numer(:), & + !$acc taf_denom(:), & + !$acc qaf_numer(:), & + !$acc qaf_denom(:), & + !$acc wtas(:), & + !$acc wtaq(:), & + !$acc wts_sum(:), & + !$acc wtq_sum(:), & + !$acc fm(:), & + !$acc wtus(:), & + !$acc wtuq(:), & + !$acc wtus_roof(:), & + !$acc wtuq_roof(:), & + !$acc wtus_road_perv(:), & + !$acc wtuq_road_perv(:), & + !$acc wtus_road_imperv(:), & + !$acc wtuq_road_imperv(:), & + !$acc wtus_sunwall(:), & + !$acc wtuq_sunwall(:), & + !$acc wtus_shadewall(:), & + !$acc wtuq_shadewall(:), & + !$acc wtus_roof_unscl(:), & + !$acc wtuq_roof_unscl(:), & + !$acc wtus_road_perv_unscl(:), & + !$acc wtuq_road_perv_unscl(:), & + !$acc wtus_road_imperv_unscl(:), & + !$acc wtuq_road_imperv_unscl(:), & + !$acc wtus_sunwall_unscl(:), & + !$acc wtuq_sunwall_unscl(:), & + !$acc wtus_shadewall_unscl(:), & + !$acc wtuq_shadewall_unscl(:), & + !$acc t_sunwall_innerl(:), & + !$acc t_shadewall_innerl(:), & + !$acc t_roof_innerl(:), & + !$acc eflx_sh_grnd_scale(:), & + !$acc qflx_evap_soi_scale(:), & + !$acc eflx_wasteheat_roof(:), & + !$acc eflx_wasteheat_sunwall(:), & + !$acc eflx_wasteheat_shadewall(:), & + !$acc eflx_heat_from_ac_roof(:), & + !$acc eflx_heat_from_ac_sunwall(:), & + !$acc eflx_heat_from_ac_shadewall(:), & + !$acc eflx(:), & + !$acc qflx(:), & + !$acc eflx_scale(:), & + !$acc qflx_scale(:), & + !$acc eflx_err(:), & + !$acc qflx_err(:), & + !$acc local_secp1(:), & + !$acc wind_speed0(:), & + !$acc wind_speed_adj(:), & + !$acc tau(:), & + !$acc tau_diff(:), & + !$acc prev_tau(:), & + !$acc prev_tau_diff(:), & + !$acc lnd_to_urban_filter(:), & + !$acc converged_landunits(:),col_to_urban_filter(:) ) + end associate end subroutine UrbanFluxes diff --git a/components/elm/src/biogeophys/UrbanParamsType.F90 b/components/elm/src/biogeophys/UrbanParamsType.F90 index ac193ab95c04..2f53b748e9ac 100644 --- a/components/elm/src/biogeophys/UrbanParamsType.F90 +++ b/components/elm/src/biogeophys/UrbanParamsType.F90 @@ -102,13 +102,12 @@ module UrbanParamsType character(len= *), parameter, public :: urban_hac_on = 'ON' character(len= *), parameter, public :: urban_wasteheat_on = 'ON_WASTEHEAT' character(len= 16), public :: urban_hac = urban_hac_off - + integer, public,parameter :: urban_hac_off_int = 0 + integer, public,parameter :: urban_hac_on_int = 1 + integer, public,parameter :: urban_wasteheat_int = 2 + integer, public :: urban_hac_int = urban_hac_off_int logical, public :: urban_traffic = .false. ! urban traffic fluxes - !$acc declare copyin(urban_hac_off ) - !$acc declare copyin(urban_hac_on ) - !$acc declare copyin(urban_wasteheat_on) - !!!$acc declare copyin(urban_hac ) - !$acc declare copyin(urban_traffic ) + !$acc declare create (urban_hac_int, urban_traffic ) !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/components/elm/src/biogeophys/UrbanRadiationMod.F90 b/components/elm/src/biogeophys/UrbanRadiationMod.F90 index 22313fc85f29..5a737df34702 100644 --- a/components/elm/src/biogeophys/UrbanRadiationMod.F90 +++ b/components/elm/src/biogeophys/UrbanRadiationMod.F90 @@ -16,10 +16,8 @@ module UrbanRadiationMod use elm_varctl , only : iulog, use_finetop_rad use abortutils , only : endrun use UrbanParamsType , only : urbanparams_type - use atm2lndType , only : atm2lnd_type use SolarAbsorbedType , only : solarabs_type use SurfaceAlbedoType , only : surfalb_type - use EnergyFluxType , only : energyflux_type use TopounitDataType , only : top_af use LandunitType , only : lun_pp use ColumnType , only : col_pp @@ -42,79 +40,68 @@ module UrbanRadiationMod contains !----------------------------------------------------------------------- - subroutine UrbanRadiation (bounds , & + subroutine UrbanRadiation ( & num_nourbanl, filter_nourbanl , & num_urbanl, filter_urbanl , & - num_urbanc, filter_urbanc , & - num_urbanp, filter_urbanp , & - atm2lnd_vars, urbanparams_vars, & - solarabs_vars, surfalb_vars, energyflux_vars) + urbanparams_vars, solarabs_vars, surfalb_vars ) ! ! !DESCRIPTION: ! Solar fluxes absorbed and reflected by roof and canyon (walls, road). ! Also net and upward longwave fluxes. ! !USES: - !$acc routine seq use elm_varcon , only : spval, sb, tfrz use column_varcon , only : icol_road_perv, icol_road_imperv use column_varcon , only : icol_roof, icol_sunwall, icol_shadewall ! ! !ARGUMENTS: - type(bounds_type) , intent(in) :: bounds integer , intent(in) :: num_nourbanl ! number of non-urban landunits in clump integer , intent(in) :: filter_nourbanl(:) ! non-urban landunit filter integer , intent(in) :: num_urbanl ! number of urban landunits in clump integer , intent(in) :: filter_urbanl(:) ! urban landunit filter - integer , intent(in) :: num_urbanc ! number of urban columns in clump - integer , intent(in) :: filter_urbanc(:) ! urban column filter - integer , intent(in) :: num_urbanp ! number of urban patches in clump - integer , intent(in) :: filter_urbanp(:) ! urban pft filter - type(atm2lnd_type) , intent(in) :: atm2lnd_vars type(urbanparams_type) , intent(in) :: urbanparams_vars type(solarabs_type) , intent(inout) :: solarabs_vars type(surfalb_type) , intent(in) :: surfalb_vars - type(energyflux_type) , intent(inout) :: energyflux_vars ! ! !LOCAL VARIABLES: - integer :: fp,fl,p,c,l,t,g ! indices - integer :: local_secp1 ! seconds into current date in local time - real(r8) :: dtime ! land model time step (sec) - integer :: year,month,day ! temporaries (not used) - integer :: secs ! seconds into current date + integer :: fp,fl,p,c,l,t,g ! indices + integer :: local_secp1 ! seconds into current date in local time + real(r8) :: dtime ! land model time step (sec) + integer :: year,month,day ! temporaries (not used) + integer :: secs ! seconds into current date real(r8), parameter :: mpe = 1.e-06_r8 ! prevents overflow for division by zero real(r8), parameter :: snoem = 0.97_r8 ! snow emissivity (should use value from Biogeophysics1) - real(r8) :: lwnet_roof(bounds%begl:bounds%endl) ! net (outgoing-incoming) longwave radiation (per unit ground area), roof (W/m**2) - real(r8) :: lwnet_improad(bounds%begl:bounds%endl) ! net (outgoing-incoming) longwave radiation (per unit ground area), impervious road (W/m**2) - real(r8) :: lwnet_perroad(bounds%begl:bounds%endl) ! net (outgoing-incoming) longwave radiation (per unit ground area), pervious road (W/m**2) - real(r8) :: lwnet_sunwall(bounds%begl:bounds%endl) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) - real(r8) :: lwnet_shadewall(bounds%begl:bounds%endl)! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) - real(r8) :: lwnet_canyon(bounds%begl:bounds%endl) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) - real(r8) :: lwup_roof(bounds%begl:bounds%endl) ! upward longwave radiation (per unit ground area), roof (W/m**2) - real(r8) :: lwup_improad(bounds%begl:bounds%endl) ! upward longwave radiation (per unit ground area), impervious road (W/m**2) - real(r8) :: lwup_perroad(bounds%begl:bounds%endl) ! upward longwave radiation (per unit ground area), pervious road (W/m**2) - real(r8) :: lwup_sunwall(bounds%begl:bounds%endl) ! upward longwave radiation, (per unit wall area), sunlit wall (W/m**2) - real(r8) :: lwup_shadewall(bounds%begl:bounds%endl) ! upward longwave radiation, (per unit wall area), shaded wall (W/m**2) - real(r8) :: lwup_canyon(bounds%begl:bounds%endl) ! upward longwave radiation for canyon, per unit ground area (W/m**2) - real(r8) :: t_roof(bounds%begl:bounds%endl) ! roof temperature (K) - real(r8) :: t_improad(bounds%begl:bounds%endl) ! imppervious road temperature (K) - real(r8) :: t_perroad(bounds%begl:bounds%endl) ! pervious road temperature (K) - real(r8) :: t_sunwall(bounds%begl:bounds%endl) ! sunlit wall temperature (K) - real(r8) :: t_shadewall(bounds%begl:bounds%endl) ! shaded wall temperature (K) - real(r8) :: lwdown(bounds%begl:bounds%endl) ! atmospheric downward longwave radiation (W/m**2) - real(r8) :: em_roof_s(bounds%begl:bounds%endl) ! roof emissivity with snow effects - real(r8) :: em_improad_s(bounds%begl:bounds%endl) ! impervious road emissivity with snow effects - real(r8) :: em_perroad_s(bounds%begl:bounds%endl) ! pervious road emissivity with snow effects + real(r8) :: lwnet_roof ! net (outgoing-incoming) longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwnet_improad ! net (outgoing-incoming) longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwnet_perroad ! net (outgoing-incoming) longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwnet_sunwall ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwnet_shadewall! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwnet_canyon ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: lwup_roof ! upward longwave radiation (per unit ground area), roof (W/m**2) + real(r8) :: lwup_improad ! upward longwave radiation (per unit ground area), impervious road (W/m**2) + real(r8) :: lwup_perroad ! upward longwave radiation (per unit ground area), pervious road (W/m**2) + real(r8) :: lwup_sunwall ! upward longwave radiation, (per unit wall area), sunlit wall (W/m**2) + real(r8) :: lwup_shadewall ! upward longwave radiation, (per unit wall area), shaded wall (W/m**2) + real(r8) :: lwup_canyon ! upward longwave radiation for canyon, per unit ground area (W/m**2) + real(r8) :: t_roof ! roof temperature (K) + real(r8) :: t_improad ! imppervious road temperature (K) + real(r8) :: t_perroad ! pervious road temperature (K) + real(r8) :: t_sunwall ! sunlit wall temperature (K) + real(r8) :: t_shadewall ! shaded wall temperature (K) + real(r8) :: lwdown ! atmospheric downward longwave radiation (W/m**2) + real(r8) :: em_roof_s ! roof emissivity with snow effects + real(r8) :: em_improad_s ! impervious road emissivity with snow effects + real(r8) :: em_perroad_s ! pervious road emissivity with snow effects !----------------------------------------------------------------------- - associate( & - ctype => col_pp%itype , & ! Input: [integer (:) ] column type - coli => lun_pp%coli , & ! Input: [integer (:) ] beginning column index for landunit - colf => lun_pp%colf , & ! Input: [integer (:) ] ending column index for landunit - canyon_hwr => lun_pp%canyon_hwr , & ! Input: [real(r8) (:) ] ratio of building height to street width - wtroad_perv => lun_pp%wtroad_perv , & ! Input: [real(r8) (:) ] weight of pervious road wrt total road + associate( & + ctype => col_pp%itype , & ! Input: [integer (:) ] column type + coli => lun_pp%coli , & ! Input: [integer (:) ] beginning column index for landunit + colf => lun_pp%colf , & ! Input: [integer (:) ] ending column index for landunit + canyon_hwr => lun_pp%canyon_hwr , & ! Input: [real(r8) (:) ] ratio of building height to street width + wtroad_perv => lun_pp%wtroad_perv , & ! Input: [real(r8) (:) ] weight of pervious road wrt total road forc_solad => top_af%solad_pp , & ! Input: [real(r8) (:,:) ] direct beam radiation under PP (vis=forc_sols , nir=forc_soll ) (W/m**2) forc_solai => top_af%solai_pp , & ! Input: [real(r8) (:,:) ] diffuse beam radiation under PP (vis=forc_sols , nir=forc_soll ) (W/m**2) @@ -124,15 +111,20 @@ subroutine UrbanRadiation (bounds , & frac_sno => col_ws%frac_sno , & ! Input: [real(r8) (:) ] fraction of ground covered by snow (0 to 1) t_ref2m => veg_es%t_ref2m , & ! Input: [real(r8) (:) ] 2 m height surface air temperature (K) - t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (K) + t_grnd => col_es%t_grnd , & ! Input: [real(r8) (:) ] ground temperature (K) em_roof => urbanparams_vars%em_roof , & ! Input: [real(r8) (:) ] roof emissivity em_improad => urbanparams_vars%em_improad , & ! Input: [real(r8) (:) ] impervious road emissivity em_perroad => urbanparams_vars%em_perroad , & ! Input: [real(r8) (:) ] pervious road emissivity em_wall => urbanparams_vars%em_wall , & ! Input: [real(r8) (:) ] wall emissivity - albd => surfalb_vars%albd_patch , & ! Input: [real(r8) (:,:) ] pft surface albedo (direct) - albi => surfalb_vars%albi_patch , & ! Input: [real(r8) (:,:) ] pft surface albedo (diffuse) + albd => surfalb_vars%albd_patch , & ! Input: [real(r8) (:,:) ] pft surface albedo (direct) + albi => surfalb_vars%albi_patch , & ! Input: [real(r8) (:,:) ] pft surface albedo (diffuse) + vf_sr => urbanparams_vars%vf_sr , & ! Input: [real(r8) (:)] view factor of sky for road + vf_wr => urbanparams_vars%vf_wr , & ! Input: [real(r8) (:)] view factor of one wall for road + vf_sw => urbanparams_vars%vf_sw , & ! Input: [real(r8) (:)] view factor of sky for one wall + vf_rw => urbanparams_vars%vf_rw , & ! Input: [real(r8) (:)] view factor of road for one wall + vf_ww => urbanparams_vars%vf_ww , & ! Input: [real(r8) (:)] view factor of opposing wall for one wall sabs_roof_dir => solarabs_vars%sabs_roof_dir_lun , & ! Output: [real(r8) (:,:) ] direct solar absorbed by roof per unit ground area per unit incident flux sabs_roof_dif => solarabs_vars%sabs_roof_dif_lun , & ! Output: [real(r8) (:,:) ] diffuse solar absorbed by roof per unit ground area per unit incident flux @@ -151,10 +143,8 @@ subroutine UrbanRadiation (bounds , & eflx_lwrad_out => veg_ef%eflx_lwrad_out , & ! Output: [real(r8) (:) ] emitted infrared (longwave) radiation (W/m**2) eflx_lwrad_net => veg_ef%eflx_lwrad_net , & ! Output: [real(r8) (:) ] net infrared (longwave) rad (W/m**2) [+ = to atm] - eflx_lwrad_net_u => veg_ef%eflx_lwrad_net_u , & ! Output: [real(r8) (:) ] urban net infrared (longwave) rad (W/m**2) [+ = to atm] + eflx_lwrad_net_u => veg_ef%eflx_lwrad_net_u & ! Output: [real(r8) (:) ] urban net infrared (longwave) rad (W/m**2) [+ = to atm] - begl => bounds%begl , & - endl => bounds%endl & ) if (.not. use_finetop_rad) then @@ -166,6 +156,7 @@ subroutine UrbanRadiation (bounds , & ! Define fields that appear on the restart file for non-urban landunits + !$acc parallel loop independent gang vector default(present) do fl = 1,num_nourbanl l = filter_nourbanl(fl) sabs_roof_dir(l,:) = spval @@ -181,6 +172,7 @@ subroutine UrbanRadiation (bounds , & end do ! Set input forcing fields + !$acc parallel loop independent gang vector default(present) do fl = 1,num_urbanl l = filter_urbanl(fl) t = lun_pp%topounit(l) @@ -189,123 +181,130 @@ subroutine UrbanRadiation (bounds , & ! Need to set the following temperatures to some defined value even if it ! does not appear in the urban landunit for the net_longwave computation - t_roof(l) = 19._r8 + tfrz - t_sunwall(l) = 19._r8 + tfrz - t_shadewall(l) = 19._r8 + tfrz - t_improad(l) = 19._r8 + tfrz - t_perroad(l) = 19._r8 + tfrz + t_roof = 19._r8 + tfrz + t_sunwall = 19._r8 + tfrz + t_shadewall = 19._r8 + tfrz + t_improad = 19._r8 + tfrz + t_perroad = 19._r8 + tfrz ! Initial assignment of emissivity - em_roof_s(l) = em_roof(l) - em_improad_s(l) = em_improad(l) - em_perroad_s(l) = em_perroad(l) + em_roof_s = em_roof(l) + em_improad_s = em_improad(l) + em_perroad_s = em_perroad(l) ! Set urban temperatures and emissivity including snow effects. + !$acc loop seq do c = coli(l),colf(l) - if (ctype(c) == icol_roof ) then - t_roof(l) = t_grnd(c) - em_roof_s(l) = em_roof(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + if (ctype(c) == icol_roof ) then + t_roof = t_grnd(c) + em_roof_s = em_roof(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) else if (ctype(c) == icol_road_imperv) then - t_improad(l) = t_grnd(c) - em_improad_s(l) = em_improad(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + t_improad = t_grnd(c) + em_improad_s = em_improad(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) else if (ctype(c) == icol_road_perv ) then - t_perroad(l) = t_grnd(c) - em_perroad_s(l) = em_perroad(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) + t_perroad = t_grnd(c) + em_perroad_s = em_perroad(l)*(1._r8-frac_sno(c)) + snoem*frac_sno(c) else if (ctype(c) == icol_sunwall ) then - t_sunwall(l) = t_grnd(c) + t_sunwall = t_grnd(c) else if (ctype(c) == icol_shadewall ) then - t_shadewall(l) = t_grnd(c) + t_shadewall = t_grnd(c) end if end do - lwdown(l) = forc_lwrad(t) - end do - - ! Net longwave radiation for road and both walls in urban canyon allowing for multiple re-emission - - if (num_urbanl > 0) then - call net_longwave (bounds, & - num_urbanl, filter_urbanl, & - canyon_hwr(begl:endl), & - wtroad_perv(begl:endl), & - lwdown(begl:endl), & - em_roof_s(begl:endl), & - em_improad_s(begl:endl), & - em_perroad_s(begl:endl), & - em_wall(begl:endl), & - t_roof(begl:endl), & - t_improad(begl:endl), & - t_perroad(begl:endl), & - t_sunwall(begl:endl), & - t_shadewall(begl:endl), & - lwnet_roof(begl:endl), & - lwnet_improad(begl:endl), & - lwnet_perroad(begl:endl), & - lwnet_sunwall(begl:endl), & - lwnet_shadewall(begl:endl), & - lwnet_canyon(begl:endl), & - lwup_roof(begl:endl), & - lwup_improad(begl:endl), & - lwup_perroad(begl:endl), & - lwup_sunwall(begl:endl), & - lwup_shadewall(begl:endl), & - lwup_canyon(begl:endl), & - urbanparams_vars) - end if + lwdown = forc_lwrad(t) + + ! Net longwave radiation for road and both walls in urban canyon allowing for multiple re-emission + ! NOTE: is it better to do surfaces independently in separate routines? + ! This would cut local variables in half and make net_longwave more readable + !if (num_urbanl > 0) then + call net_longwave ( & + canyon_hwr(l), & + wtroad_perv(l), & + lwdown, & + em_roof_s, & + em_improad_s, & + em_perroad_s, & + em_wall(l), & + t_roof, & + t_improad, & + t_perroad, & + t_sunwall, & + t_shadewall, & + lwnet_roof, & + lwnet_improad, & + lwnet_perroad, & + lwnet_sunwall, & + lwnet_shadewall, & + lwnet_canyon, & + lwup_roof, & + lwup_improad, & + lwup_perroad, & + lwup_sunwall, & + lwup_shadewall, & + lwup_canyon, & + vf_sr(l), vf_wr(l), vf_sw(l), vf_rw(l), vf_ww(l)) + + ! end if ! Determine variables needed for history output and communication with atm ! Loop over urban patches in clump + !NOTE: Rewrote this loop to have all landunit calcs within one overall loop. + ! This saves local memory allocations. - do fp = 1,num_urbanp - p = filter_urbanp(fp) - c = veg_pp%column(p) - l = veg_pp%landunit(p) - t = veg_pp%topounit(p) - g = veg_pp%gridcell(p) + !$acc loop seq + do p = lun_pp%pfti(l), lun_pp%pftf(l) + !!are all patches on a active lanunit also active? + if(.not. veg_pp%active(p)) then + cycle + end if + + g = veg_pp%gridcell(p) + t = veg_pp%topounit(p) + c = veg_pp%column(p) ! Solar absorbed and longwave out and net ! per unit ground area (roof, road) and per unit wall area (sunwall, shadewall) ! Each urban pft has its own column - this is used in the logic below if (ctype(c) == icol_roof) then - eflx_lwrad_out(p) = lwup_roof(l) - eflx_lwrad_net(p) = lwnet_roof(l) - eflx_lwrad_net_u(p) = lwnet_roof(l) + eflx_lwrad_out(p) = lwup_roof + eflx_lwrad_net(p) = lwnet_roof + eflx_lwrad_net_u(p) = lwnet_roof sabg(p) = sabs_roof_dir(l,1)*forc_solad(t,1) + & sabs_roof_dif(l,1)*forc_solai(t,1) + & sabs_roof_dir(l,2)*forc_solad(t,2) + & sabs_roof_dif(l,2)*forc_solai(t,2) else if (ctype(c) == icol_sunwall) then - eflx_lwrad_out(p) = lwup_sunwall(l) - eflx_lwrad_net(p) = lwnet_sunwall(l) - eflx_lwrad_net_u(p) = lwnet_sunwall(l) + eflx_lwrad_out(p) = lwup_sunwall + eflx_lwrad_net(p) = lwnet_sunwall + eflx_lwrad_net_u(p) = lwnet_sunwall sabg(p) = sabs_sunwall_dir(l,1)*forc_solad(t,1) + & sabs_sunwall_dif(l,1)*forc_solai(t,1) + & sabs_sunwall_dir(l,2)*forc_solad(t,2) + & sabs_sunwall_dif(l,2)*forc_solai(t,2) else if (ctype(c) == icol_shadewall) then - eflx_lwrad_out(p) = lwup_shadewall(l) - eflx_lwrad_net(p) = lwnet_shadewall(l) - eflx_lwrad_net_u(p) = lwnet_shadewall(l) + eflx_lwrad_out(p) = lwup_shadewall + eflx_lwrad_net(p) = lwnet_shadewall + eflx_lwrad_net_u(p) = lwnet_shadewall sabg(p) = sabs_shadewall_dir(l,1)*forc_solad(t,1) + & sabs_shadewall_dif(l,1)*forc_solai(t,1) + & sabs_shadewall_dir(l,2)*forc_solad(t,2) + & sabs_shadewall_dif(l,2)*forc_solai(t,2) else if (ctype(c) == icol_road_perv) then - eflx_lwrad_out(p) = lwup_perroad(l) - eflx_lwrad_net(p) = lwnet_perroad(l) - eflx_lwrad_net_u(p) = lwnet_perroad(l) + eflx_lwrad_out(p) = lwup_perroad + eflx_lwrad_net(p) = lwnet_perroad + eflx_lwrad_net_u(p) = lwnet_perroad sabg(p) = sabs_perroad_dir(l,1)*forc_solad(t,1) + & sabs_perroad_dif(l,1)*forc_solai(t,1) + & sabs_perroad_dir(l,2)*forc_solad(t,2) + & sabs_perroad_dif(l,2)*forc_solai(t,2) else if (ctype(c) == icol_road_imperv) then - eflx_lwrad_out(p) = lwup_improad(l) - eflx_lwrad_net(p) = lwnet_improad(l) - eflx_lwrad_net_u(p) = lwnet_improad(l) + eflx_lwrad_out(p) = lwup_improad + eflx_lwrad_net(p) = lwnet_improad + eflx_lwrad_net_u(p) = lwnet_improad sabg(p) = sabs_improad_dir(l,1)*forc_solad(t,1) + & sabs_improad_dif(l,1)*forc_solai(t,1) + & sabs_improad_dir(l,2)*forc_solad(t,2) + & @@ -318,244 +317,223 @@ subroutine UrbanRadiation (bounds , & end do ! end loop over urban patches + end do ! end loop over urban landunit + end associate end subroutine UrbanRadiation !----------------------------------------------------------------------- - subroutine net_longwave (bounds , & - num_urbanl, filter_urbanl, canyon_hwr, wtroad_perv , & - lwdown, em_roof, em_improad, em_perroad, em_wall , & - t_roof, t_improad, t_perroad, t_sunwall, t_shadewall , & + subroutine net_longwave (canyon_hwr, wtroad_perv , & + lwdown, em_roof, em_improad, em_perroad, em_wall , & + t_roof, t_improad, t_perroad, t_sunwall, t_shadewall , & lwnet_roof, lwnet_improad, lwnet_perroad, lwnet_sunwall, lwnet_shadewall, lwnet_canyon , & lwup_roof, lwup_improad, lwup_perroad, lwup_sunwall, lwup_shadewall, lwup_canyon, & - urbanparams_vars) - ! + vf_sr, vf_wr, vf_sw, vf_rw, vf_ww) + !$acc routine seq ! !DESCRIPTION: ! Net longwave radiation for road and both walls in urban canyon allowing for ! multiple reflection. Also net longwave radiation for urban roof. ! ! !USES: - !$acc routine seq use elm_varcon , only : sb ! ! !ARGUMENTS: - type(bounds_type), intent(in) :: bounds - integer , intent(in) :: num_urbanl ! number of urban landunits - integer , intent(in) :: filter_urbanl(:) ! urban landunit filter - real(r8), intent(in) :: canyon_hwr( bounds%begl: ) ! ratio of building height to street width [landunit] - real(r8), intent(in) :: wtroad_perv( bounds%begl: ) ! weight of pervious road wrt total road [landunit] - - real(r8), intent(in) :: lwdown( bounds%begl: ) ! atmospheric longwave radiation (W/m**2) [landunit] - real(r8), intent(in) :: em_roof( bounds%begl: ) ! roof emissivity [landunit] - real(r8), intent(in) :: em_improad( bounds%begl: ) ! impervious road emissivity [landunit] - real(r8), intent(in) :: em_perroad( bounds%begl: ) ! pervious road emissivity [landunit] - real(r8), intent(in) :: em_wall( bounds%begl: ) ! wall emissivity [landunit] - - real(r8), intent(in) :: t_roof( bounds%begl: ) ! roof temperature (K) [landunit] - real(r8), intent(in) :: t_improad( bounds%begl: ) ! impervious road temperature (K) [landunit] - real(r8), intent(in) :: t_perroad( bounds%begl: ) ! ervious road temperature (K) [landunit] - real(r8), intent(in) :: t_sunwall( bounds%begl: ) ! sunlit wall temperature (K) [landunit] - real(r8), intent(in) :: t_shadewall( bounds%begl: ) ! shaded wall temperature (K) [landunit] - - real(r8), intent(out) :: lwnet_roof( bounds%begl: ) ! net (outgoing-incoming) longwave radiation, roof (W/m**2) [landunit] - real(r8), intent(out) :: lwnet_improad( bounds%begl: ) ! net (outgoing-incoming) longwave radiation, impervious road (W/m**2) [landunit] - real(r8), intent(out) :: lwnet_perroad( bounds%begl: ) ! net (outgoing-incoming) longwave radiation, pervious road (W/m**2) [landunit] - real(r8), intent(out) :: lwnet_sunwall( bounds%begl: ) ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) [landunit] - real(r8), intent(out) :: lwnet_shadewall( bounds%begl: ) ! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) [landunit] - real(r8), intent(out) :: lwnet_canyon( bounds%begl: ) ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) [landunit] - - real(r8), intent(out) :: lwup_roof( bounds%begl: ) ! upward longwave radiation, roof (W/m**2) [landunit] - real(r8), intent(out) :: lwup_improad( bounds%begl: ) ! upward longwave radiation, impervious road (W/m**2) [landunit] - real(r8), intent(out) :: lwup_perroad( bounds%begl: ) ! upward longwave radiation, pervious road (W/m**2) [landunit] - real(r8), intent(out) :: lwup_sunwall( bounds%begl: ) ! upward longwave radiation (per unit wall area), sunlit wall (W/m**2) [landunit] - real(r8), intent(out) :: lwup_shadewall( bounds%begl: ) ! upward longwave radiation (per unit wall area), shaded wall (W/m**2) [landunit] - real(r8), intent(out) :: lwup_canyon( bounds%begl: ) ! upward longwave radiation for canyon, per unit ground area (W/m**2) [landunit] + real(r8), intent(in) :: canyon_hwr ! ratio of building height to street width [landunit] + real(r8), intent(in) :: wtroad_perv ! weight of pervious road wrt total road [landunit] + + real(r8), intent(in) :: lwdown ! atmospheric longwave radiation (W/m**2) [landunit] + real(r8), intent(in) :: em_roof ! roof emissivity [landunit] + real(r8), intent(in) :: em_improad ! impervious road emissivity [landunit] + real(r8), intent(in) :: em_perroad ! pervious road emissivity [landunit] + real(r8), intent(in) :: em_wall ! wall emissivity [landunit] + + real(r8), intent(in) :: t_roof ! roof temperature (K) [landunit] + real(r8), intent(in) :: t_improad ! impervious road temperature (K) [landunit] + real(r8), intent(in) :: t_perroad ! ervious road temperature (K) [landunit] + real(r8), intent(in) :: t_sunwall ! sunlit wall temperature (K) [landunit] + real(r8), intent(in) :: t_shadewall ! shaded wall temperature (K) [landunit] + + real(r8), intent(out) :: lwnet_roof ! net (outgoing-incoming) longwave radiation, roof (W/m**2) [landunit] + real(r8), intent(out) :: lwnet_improad ! net (outgoing-incoming) longwave radiation, impervious road (W/m**2) [landunit] + real(r8), intent(out) :: lwnet_perroad ! net (outgoing-incoming) longwave radiation, pervious road (W/m**2) [landunit] + real(r8), intent(out) :: lwnet_sunwall ! net (outgoing-incoming) longwave radiation (per unit wall area), sunlit wall (W/m**2) [landunit] + real(r8), intent(out) :: lwnet_shadewall! net (outgoing-incoming) longwave radiation (per unit wall area), shaded wall (W/m**2) [landunit] + real(r8), intent(out) :: lwnet_canyon ! net (outgoing-incoming) longwave radiation for canyon, per unit ground area (W/m**2) [landunit] + + real(r8), intent(out) :: lwup_roof ! upward longwave radiation, roof (W/m**2) [landunit] + real(r8), intent(out) :: lwup_improad ! upward longwave radiation, impervious road (W/m**2) [landunit] + real(r8), intent(out) :: lwup_perroad ! upward longwave radiation, pervious road (W/m**2) [landunit] + real(r8), intent(out) :: lwup_sunwall ! upward longwave radiation (per unit wall area), sunlit wall (W/m**2) [landunit] + real(r8), intent(out) :: lwup_shadewall ! upward longwave radiation (per unit wall area), shaded wall (W/m**2) [landunit] + real(r8), intent(out) :: lwup_canyon ! upward longwave radiation for canyon, per unit ground area (W/m**2) [landunit] ! - type(urbanparams_type) , intent(in) :: urbanparams_vars + real(r8), intent(in) :: vf_sr ! Input: [real(r8) (:)] urbanparams_vars%vf_sr view factor of sky for road + real(r8), intent(in) :: vf_wr ! Input: [real(r8) (:)] urbanparams_vars%vf_wr view factor of one wall for road + real(r8), intent(in) :: vf_sw ! Input: [real(r8) (:)] urbanparams_vars%vf_sw view factor of sky for one wall + real(r8), intent(in) :: vf_rw ! Input: [real(r8) (:)] urbanparams_vars%vf_rw view factor of road for one wall + real(r8), intent(in) :: vf_ww ! Input: [real(r8) (:)] urbanparams_vars%vf_ww view factor of opposing wall for one wall + ! ! !LOCAL VARIABLES: - real(r8) :: lwdown_road(bounds%begl:bounds%endl) ! atmospheric longwave radiation for total road (W/m**2) - real(r8) :: lwdown_sunwall(bounds%begl:bounds%endl) ! atmospheric longwave radiation (per unit wall area) for sunlit wall (W/m**2) - real(r8) :: lwdown_shadewall(bounds%begl:bounds%endl) ! atmospheric longwave radiation (per unit wall area) for shaded wall (W/m**2) - real(r8) :: lwtot(bounds%begl:bounds%endl) ! incoming longwave radiation (W/m**2) - - real(r8) :: improad_a(bounds%begl:bounds%endl) ! absorbed longwave for improad (W/m**2) - real(r8) :: improad_r(bounds%begl:bounds%endl) ! reflected longwave for improad (W/m**2) - real(r8) :: improad_r_sky(bounds%begl:bounds%endl) ! improad_r to sky (W/m**2) - real(r8) :: improad_r_sunwall(bounds%begl:bounds%endl) ! improad_r to sunlit wall (W/m**2) - real(r8) :: improad_r_shadewall(bounds%begl:bounds%endl) ! improad_r to shaded wall (W/m**2) - real(r8) :: improad_e(bounds%begl:bounds%endl) ! emitted longwave for improad (W/m**2) - real(r8) :: improad_e_sky(bounds%begl:bounds%endl) ! improad_e to sky (W/m**2) - real(r8) :: improad_e_sunwall(bounds%begl:bounds%endl) ! improad_e to sunlit wall (W/m**2) - real(r8) :: improad_e_shadewall(bounds%begl:bounds%endl) ! improad_e to shaded wall (W/m**2) - - real(r8) :: perroad_a(bounds%begl:bounds%endl) ! absorbed longwave for perroad (W/m**2) - real(r8) :: perroad_r(bounds%begl:bounds%endl) ! reflected longwave for perroad (W/m**2) - real(r8) :: perroad_r_sky(bounds%begl:bounds%endl) ! perroad_r to sky (W/m**2) - real(r8) :: perroad_r_sunwall(bounds%begl:bounds%endl) ! perroad_r to sunlit wall (W/m**2) - real(r8) :: perroad_r_shadewall(bounds%begl:bounds%endl) ! perroad_r to shaded wall (W/m**2) - real(r8) :: perroad_e(bounds%begl:bounds%endl) ! emitted longwave for perroad (W/m**2) - real(r8) :: perroad_e_sky(bounds%begl:bounds%endl) ! perroad_e to sky (W/m**2) - real(r8) :: perroad_e_sunwall(bounds%begl:bounds%endl) ! perroad_e to sunlit wall (W/m**2) - real(r8) :: perroad_e_shadewall(bounds%begl:bounds%endl) ! perroad_e to shaded wall (W/m**2) - - real(r8) :: road_a(bounds%begl:bounds%endl) ! absorbed longwave for total road (W/m**2) - real(r8) :: road_r(bounds%begl:bounds%endl) ! reflected longwave for total road (W/m**2) - real(r8) :: road_r_sky(bounds%begl:bounds%endl) ! total road_r to sky (W/m**2) - real(r8) :: road_r_sunwall(bounds%begl:bounds%endl) ! total road_r to sunlit wall (W/m**2) - real(r8) :: road_r_shadewall(bounds%begl:bounds%endl) ! total road_r to shaded wall (W/m**2) - real(r8) :: road_e(bounds%begl:bounds%endl) ! emitted longwave for total road (W/m**2) - real(r8) :: road_e_sky(bounds%begl:bounds%endl) ! total road_e to sky (W/m**2) - real(r8) :: road_e_sunwall(bounds%begl:bounds%endl) ! total road_e to sunlit wall (W/m**2) - real(r8) :: road_e_shadewall(bounds%begl:bounds%endl) ! total road_e to shaded wall (W/m**2) - - real(r8) :: sunwall_a(bounds%begl:bounds%endl) ! absorbed longwave (per unit wall area) for sunlit wall (W/m**2) - real(r8) :: sunwall_r(bounds%begl:bounds%endl) ! reflected longwave (per unit wall area) for sunlit wall (W/m**2) - real(r8) :: sunwall_r_sky(bounds%begl:bounds%endl) ! sunwall_r to sky (W/m**2) - real(r8) :: sunwall_r_road(bounds%begl:bounds%endl) ! sunwall_r to road (W/m**2) - real(r8) :: sunwall_r_shadewall(bounds%begl:bounds%endl) ! sunwall_r to opposing (shaded) wall (W/m**2) - real(r8) :: sunwall_e(bounds%begl:bounds%endl) ! emitted longwave (per unit wall area) for sunlit wall (W/m**2) - real(r8) :: sunwall_e_sky(bounds%begl:bounds%endl) ! sunwall_e to sky (W/m**2) - real(r8) :: sunwall_e_road(bounds%begl:bounds%endl) ! sunwall_e to road (W/m**2) - real(r8) :: sunwall_e_shadewall(bounds%begl:bounds%endl) ! sunwall_e to opposing (shaded) wall (W/m**2) - - real(r8) :: shadewall_a(bounds%begl:bounds%endl) ! absorbed longwave (per unit wall area) for shaded wall (W/m**2) - real(r8) :: shadewall_r(bounds%begl:bounds%endl) ! reflected longwave (per unit wall area) for shaded wall (W/m**2) - real(r8) :: shadewall_r_sky(bounds%begl:bounds%endl) ! shadewall_r to sky (W/m**2) - real(r8) :: shadewall_r_road(bounds%begl:bounds%endl) ! shadewall_r to road (W/m**2) - real(r8) :: shadewall_r_sunwall(bounds%begl:bounds%endl) ! shadewall_r to opposing (sunlit) wall (W/m**2) - real(r8) :: shadewall_e(bounds%begl:bounds%endl) ! emitted longwave (per unit wall area) for shaded wall (W/m**2) - real(r8) :: shadewall_e_sky(bounds%begl:bounds%endl) ! shadewall_e to sky (W/m**2) - real(r8) :: shadewall_e_road(bounds%begl:bounds%endl) ! shadewall_e to road (W/m**2) - real(r8) :: shadewall_e_sunwall(bounds%begl:bounds%endl) ! shadewall_e to opposing (sunlit) wall (W/m**2) - integer :: l,fl,iter ! indices - integer, parameter :: n = 50 ! number of interations - real(r8) :: crit ! convergence criterion (W/m**2) - real(r8) :: err ! energy conservation error (W/m**2) - real(r8) :: wtroad_imperv(bounds%begl:bounds%endl) ! weight of impervious road wrt total road + real(r8) :: lwdown_road ! atmospheric longwave radiation for total road (W/m**2) + real(r8) :: lwdown_sunwall ! atmospheric longwave radiation (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: lwdown_shadewall ! atmospheric longwave radiation (per unit wall area) for shaded wall (W/m**2) + real(r8) :: lwtot ! incoming longwave radiation (W/m**2) + + real(r8) :: improad_a ! absorbed longwave for improad (W/m**2) + real(r8) :: improad_r ! reflected longwave for improad (W/m**2) + real(r8) :: improad_r_sky ! improad_r to sky (W/m**2) + real(r8) :: improad_r_sunwall ! improad_r to sunlit wall (W/m**2) + real(r8) :: improad_r_shadewall ! improad_r to shaded wall (W/m**2) + real(r8) :: improad_e ! emitted longwave for improad (W/m**2) + real(r8) :: improad_e_sky ! improad_e to sky (W/m**2) + real(r8) :: improad_e_sunwall ! improad_e to sunlit wall (W/m**2) + real(r8) :: improad_e_shadewall ! improad_e to shaded wall (W/m**2) + + real(r8) :: perroad_a ! absorbed longwave for perroad (W/m**2) + real(r8) :: perroad_r ! reflected longwave for perroad (W/m**2) + real(r8) :: perroad_r_sky ! perroad_r to sky (W/m**2) + real(r8) :: perroad_r_sunwall ! perroad_r to sunlit wall (W/m**2) + real(r8) :: perroad_r_shadewall ! perroad_r to shaded wall (W/m**2) + real(r8) :: perroad_e ! emitted longwave for perroad (W/m**2) + real(r8) :: perroad_e_sky ! perroad_e to sky (W/m**2) + real(r8) :: perroad_e_sunwall ! perroad_e to sunlit wall (W/m**2) + real(r8) :: perroad_e_shadewall ! perroad_e to shaded wall (W/m**2) + + real(r8) :: road_a ! absorbed longwave for total road (W/m**2) + real(r8) :: road_r ! reflected longwave for total road (W/m**2) + real(r8) :: road_r_sky ! total road_r to sky (W/m**2) + real(r8) :: road_r_sunwall ! total road_r to sunlit wall (W/m**2) + real(r8) :: road_r_shadewall ! total road_r to shaded wall (W/m**2) + real(r8) :: road_e ! emitted longwave for total road (W/m**2) + real(r8) :: road_e_sky ! total road_e to sky (W/m**2) + real(r8) :: road_e_sunwall ! total road_e to sunlit wall (W/m**2) + real(r8) :: road_e_shadewall ! total road_e to shaded wall (W/m**2) + + real(r8) :: sunwall_a ! absorbed longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r ! reflected longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_r_sky ! sunwall_r to sky (W/m**2) + real(r8) :: sunwall_r_road ! sunwall_r to road (W/m**2) + real(r8) :: sunwall_r_shadewall ! sunwall_r to opposing (shaded) wall (W/m**2) + real(r8) :: sunwall_e ! emitted longwave (per unit wall area) for sunlit wall (W/m**2) + real(r8) :: sunwall_e_sky ! sunwall_e to sky (W/m**2) + real(r8) :: sunwall_e_road ! sunwall_e to road (W/m**2) + real(r8) :: sunwall_e_shadewall ! sunwall_e to opposing (shaded) wall (W/m**2) + + real(r8) :: shadewall_a ! absorbed longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r ! reflected longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_r_sky ! shadewall_r to sky (W/m**2) + real(r8) :: shadewall_r_road ! shadewall_r to road (W/m**2) + real(r8) :: shadewall_r_sunwall ! shadewall_r to opposing (sunlit) wall (W/m**2) + real(r8) :: shadewall_e ! emitted longwave (per unit wall area) for shaded wall (W/m**2) + real(r8) :: shadewall_e_sky ! shadewall_e to sky (W/m**2) + real(r8) :: shadewall_e_road ! shadewall_e to road (W/m**2) + real(r8) :: shadewall_e_sunwall ! shadewall_e to opposing (sunlit) wall (W/m**2) + integer :: fl,iter ! indices + integer, parameter :: n = 50 ! number of interations + real(r8) :: crit ! convergence criterion (W/m**2) + real(r8) :: err ! energy conservation error (W/m**2) + real(r8) :: wtroad_imperv ! weight of impervious road wrt total road !----------------------------------------------------------------------- - ! Enforce expected array sizes - - - associate( & - vf_sr => urbanparams_vars%vf_sr , & ! Input: [real(r8) (:)] view factor of sky for road - vf_wr => urbanparams_vars%vf_wr , & ! Input: [real(r8) (:)] view factor of one wall for road - vf_sw => urbanparams_vars%vf_sw , & ! Input: [real(r8) (:)] view factor of sky for one wall - vf_rw => urbanparams_vars%vf_rw , & ! Input: [real(r8) (:)] view factor of road for one wall - vf_ww => urbanparams_vars%vf_ww & ! Input: [real(r8) (:)] view factor of opposing wall for one wall - ) - ! Calculate impervious road - do fl = 1,num_urbanl - l = filter_urbanl(fl) - wtroad_imperv(l) = 1._r8 - wtroad_perv(l) - end do + wtroad_imperv = 1._r8 - wtroad_perv - do fl = 1,num_urbanl - l = filter_urbanl(fl) - ! atmospheric longwave radiation incident on walls and road in urban canyon. - ! check for conservation (need to convert wall fluxes to ground area). - ! lwdown (from atmosphere) = lwdown_road + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + ! atmospheric longwave radiation incident on walls and road in urban canyon. + ! check for conservation (need to convert wall fluxes to ground area). + ! lwdown (from atmosphere) = lwdown_road + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr + lwdown_road = lwdown + lwdown_road = lwdown * vf_sr + lwdown_sunwall = lwdown * vf_sw + lwdown_shadewall = lwdown * vf_sw - lwdown_road(l) = lwdown(l) * vf_sr(l) - lwdown_sunwall(l) = lwdown(l) * vf_sw(l) - lwdown_shadewall(l) = lwdown(l) * vf_sw(l) - - err = lwdown(l) - (lwdown_road(l) + (lwdown_shadewall(l) + lwdown_sunwall(l))*canyon_hwr(l)) - if (abs(err) > 0.10_r8 ) then + err = lwdown - (lwdown_road + (lwdown_shadewall + lwdown_sunwall)*canyon_hwr) + if (abs(err) > 0.10_r8 ) then #ifndef _OPENACC - write(iulog,*) 'urban incident atmospheric longwave radiation balance error',err - write(iulog,*) 'l = ',l - write(iulog,*) 'lwdown = ',lwdown(l) - write(iulog,*) 'vf_sr = ',vf_sr(l) - write(iulog,*) 'vf_sw = ',vf_sw(l) - write(iulog,*) 'canyon_hwr = ',canyon_hwr(l) - write(iulog,*) 'elm model is stopping' - call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + write(iulog,*) 'urban incident atmospheric longwave radiation balance error',err + write(iulog,*) 'lwdown = ',lwdown + write(iulog,*) 'vf_sr = ',vf_sr + write(iulog,*) 'vf_sw = ',vf_sw + write(iulog,*) 'canyon_hwr = ',canyon_hwr + write(iulog,*) 'elm model is stopping' + call endrun() #endif - endif - end do - - do fl = 1,num_urbanl - l = filter_urbanl(fl) - - ! initial absorption, reflection, and emission for road and both walls. - ! distribute reflected and emitted radiation to sky, road, and walls according - ! to appropriate view factor. radiation reflected to road and walls will - ! undergo multiple reflections within the canyon. - - road_a(l) = 0.0_r8 - road_r(l) = 0.0_r8 - road_e(l) = 0.0_r8 - improad_a(l) = em_improad(l) * lwdown_road(l) - improad_r(l) = (1._r8-em_improad(l)) * lwdown_road(l) - improad_r_sky(l) = improad_r(l) * vf_sr(l) - improad_r_sunwall(l) = improad_r(l) * vf_wr(l) - improad_r_shadewall(l) = improad_r(l) * vf_wr(l) - improad_e(l) = em_improad(l) * sb * (t_improad(l)**4) - improad_e_sky(l) = improad_e(l) * vf_sr(l) - improad_e_sunwall(l) = improad_e(l) * vf_wr(l) - improad_e_shadewall(l) = improad_e(l) * vf_wr(l) - road_a(l) = road_a(l) + improad_a(l)*wtroad_imperv(l) - road_r(l) = road_r(l) + improad_r(l)*wtroad_imperv(l) - road_e(l) = road_e(l) + improad_e(l)*wtroad_imperv(l) - - perroad_a(l) = em_perroad(l) * lwdown_road(l) - perroad_r(l) = (1._r8-em_perroad(l)) * lwdown_road(l) - perroad_r_sky(l) = perroad_r(l) * vf_sr(l) - perroad_r_sunwall(l) = perroad_r(l) * vf_wr(l) - perroad_r_shadewall(l) = perroad_r(l) * vf_wr(l) - perroad_e(l) = em_perroad(l) * sb * (t_perroad(l)**4) - perroad_e_sky(l) = perroad_e(l) * vf_sr(l) - perroad_e_sunwall(l) = perroad_e(l) * vf_wr(l) - perroad_e_shadewall(l) = perroad_e(l) * vf_wr(l) - road_a(l) = road_a(l) + perroad_a(l)*wtroad_perv(l) - road_r(l) = road_r(l) + perroad_r(l)*wtroad_perv(l) - road_e(l) = road_e(l) + perroad_e(l)*wtroad_perv(l) - - road_r_sky(l) = road_r(l) * vf_sr(l) - road_r_sunwall(l) = road_r(l) * vf_wr(l) - road_r_shadewall(l) = road_r(l) * vf_wr(l) - road_e_sky(l) = road_e(l) * vf_sr(l) - road_e_sunwall(l) = road_e(l) * vf_wr(l) - road_e_shadewall(l) = road_e(l) * vf_wr(l) - - sunwall_a(l) = em_wall(l) * lwdown_sunwall(l) - sunwall_r(l) = (1._r8-em_wall(l)) * lwdown_sunwall(l) - sunwall_r_sky(l) = sunwall_r(l) * vf_sw(l) - sunwall_r_road(l) = sunwall_r(l) * vf_rw(l) - sunwall_r_shadewall(l) = sunwall_r(l) * vf_ww(l) - sunwall_e(l) = em_wall(l) * sb * (t_sunwall(l)**4) - sunwall_e_sky(l) = sunwall_e(l) * vf_sw(l) - sunwall_e_road(l) = sunwall_e(l) * vf_rw(l) - sunwall_e_shadewall(l) = sunwall_e(l) * vf_ww(l) - - shadewall_a(l) = em_wall(l) * lwdown_shadewall(l) - shadewall_r(l) = (1._r8-em_wall(l)) * lwdown_shadewall(l) - shadewall_r_sky(l) = shadewall_r(l) * vf_sw(l) - shadewall_r_road(l) = shadewall_r(l) * vf_rw(l) - shadewall_r_sunwall(l) = shadewall_r(l) * vf_ww(l) - shadewall_e(l) = em_wall(l) * sb * (t_shadewall(l)**4) - shadewall_e_sky(l) = shadewall_e(l) * vf_sw(l) - shadewall_e_road(l) = shadewall_e(l) * vf_rw(l) - shadewall_e_sunwall(l) = shadewall_e(l) * vf_ww(l) - - ! initialize sum of net and upward longwave radiation for road and both walls - - lwnet_improad(l) = improad_e(l) - improad_a(l) - lwnet_perroad(l) = perroad_e(l) - perroad_a(l) - lwnet_sunwall(l) = sunwall_e(l) - sunwall_a(l) - lwnet_shadewall(l) = shadewall_e(l) - shadewall_a(l) - - lwup_improad(l) = improad_r_sky(l) + improad_e_sky(l) - lwup_perroad(l) = perroad_r_sky(l) + perroad_e_sky(l) - lwup_sunwall(l) = sunwall_r_sky(l) + sunwall_e_sky(l) - lwup_shadewall(l) = shadewall_r_sky(l) + shadewall_e_sky(l) - - end do + endif + + ! initial absorption, reflection, and emission for road and both walls. + ! distribute reflected and emitted radiation to sky, road, and walls according + ! to appropriate view factor. radiation reflected to road and walls will + ! undergo multiple reflections within the canyon. + + road_a = 0.0_r8 + road_r = 0.0_r8 + road_e = 0.0_r8 + improad_a = em_improad * lwdown_road + improad_r = (1._r8-em_improad ) * lwdown_road + improad_r_sky = improad_r * vf_sr + improad_r_sunwall = improad_r * vf_wr + improad_r_shadewall = improad_r * vf_wr + improad_e = em_improad * sb * (t_improad **4) + improad_e_sky = improad_e * vf_sr + improad_e_sunwall = improad_e * vf_wr + improad_e_shadewall = improad_e * vf_wr + road_a = road_a + improad_a *wtroad_imperv + road_r = road_r + improad_r *wtroad_imperv + road_e = road_e + improad_e *wtroad_imperv + + perroad_a = em_perroad * lwdown_road + perroad_r = (1._r8-em_perroad ) * lwdown_road + perroad_r_sky = perroad_r * vf_sr + perroad_r_sunwall = perroad_r * vf_wr + perroad_r_shadewall = perroad_r * vf_wr + perroad_e = em_perroad * sb * (t_perroad **4) + perroad_e_sky = perroad_e * vf_sr + perroad_e_sunwall = perroad_e * vf_wr + perroad_e_shadewall = perroad_e * vf_wr + road_a = road_a + perroad_a *wtroad_perv + road_r = road_r + perroad_r *wtroad_perv + road_e = road_e + perroad_e *wtroad_perv + + road_r_sky = road_r * vf_sr + road_r_sunwall = road_r * vf_wr + road_r_shadewall = road_r * vf_wr + road_e_sky = road_e * vf_sr + road_e_sunwall = road_e * vf_wr + road_e_shadewall = road_e * vf_wr + + sunwall_a = em_wall * lwdown_sunwall + sunwall_r = (1._r8-em_wall ) * lwdown_sunwall + sunwall_r_sky = sunwall_r * vf_sw + sunwall_r_road = sunwall_r * vf_rw + sunwall_r_shadewall = sunwall_r * vf_ww + sunwall_e = em_wall * sb * (t_sunwall **4) + sunwall_e_sky = sunwall_e * vf_sw + sunwall_e_road = sunwall_e * vf_rw + sunwall_e_shadewall = sunwall_e * vf_ww + + shadewall_a = em_wall * lwdown_shadewall + shadewall_r = (1._r8-em_wall ) * lwdown_shadewall + shadewall_r_sky = shadewall_r * vf_sw + shadewall_r_road = shadewall_r * vf_rw + shadewall_r_sunwall = shadewall_r * vf_ww + shadewall_e = em_wall * sb * (t_shadewall **4) + shadewall_e_sky = shadewall_e * vf_sw + shadewall_e_road = shadewall_e * vf_rw + shadewall_e_sunwall = shadewall_e * vf_ww + + ! initialize sum of net and upward longwave radiation for road and both walls + + lwnet_improad = improad_e - improad_a + lwnet_perroad = perroad_e - perroad_a + lwnet_sunwall = sunwall_e - sunwall_a + lwnet_shadewall = shadewall_e - shadewall_a + + lwup_improad = improad_r_sky + improad_e_sky + lwup_perroad = perroad_r_sky + perroad_e_sky + lwup_sunwall = sunwall_r_sky + sunwall_e_sky + lwup_shadewall = shadewall_r_sky + shadewall_e_sky ! now account for absorption and reflection within canyon of fluxes from road and walls ! allowing for multiple reflections @@ -575,129 +553,120 @@ subroutine net_longwave (bounds ! (5) stop iteration when absorption for ith reflection is less than some nominal amount. ! small convergence criteria is required to ensure radiation is conserved - do fl = 1,num_urbanl - l = filter_urbanl(fl) - - do iter = 1, n - ! step (1) - - lwtot(l) = (sunwall_r_road(l) + sunwall_e_road(l) & - + shadewall_r_road(l) + shadewall_e_road(l))*canyon_hwr(l) - road_a(l) = 0.0_r8 - road_r(l) = 0.0_r8 - improad_r(l) = (1._r8-em_improad(l)) * lwtot(l) - improad_a(l) = em_improad(l) * lwtot(l) - road_a(l) = road_a(l) + improad_a(l)*wtroad_imperv(l) - road_r(l) = road_r(l) + improad_r(l)*wtroad_imperv(l) - perroad_r(l) = (1._r8-em_perroad(l)) * lwtot(l) - perroad_a(l) = em_perroad(l) * lwtot(l) - road_a(l) = road_a(l) + perroad_a(l)*wtroad_perv(l) - road_r(l) = road_r(l) + perroad_r(l)*wtroad_perv(l) - - lwtot(l) = (road_r_sunwall(l) + road_e_sunwall(l))/canyon_hwr(l) & - + (shadewall_r_sunwall(l) + shadewall_e_sunwall(l)) - sunwall_a(l) = em_wall(l) * lwtot(l) - sunwall_r(l) = (1._r8-em_wall(l)) * lwtot(l) - - lwtot(l) = (road_r_shadewall(l) + road_e_shadewall(l))/canyon_hwr(l) & - + (sunwall_r_shadewall(l) + sunwall_e_shadewall(l)) - shadewall_a(l) = em_wall(l) * lwtot(l) - shadewall_r(l) = (1._r8-em_wall(l)) * lwtot(l) - - sunwall_e_road(l) = 0._r8 - shadewall_e_road(l) = 0._r8 - road_e_sunwall(l) = 0._r8 - shadewall_e_sunwall(l) = 0._r8 - road_e_shadewall(l) = 0._r8 - sunwall_e_shadewall(l) = 0._r8 - - ! step (2) - - lwnet_improad(l) = lwnet_improad(l) - improad_a(l) - lwnet_perroad(l) = lwnet_perroad(l) - perroad_a(l) - lwnet_sunwall(l) = lwnet_sunwall(l) - sunwall_a(l) - lwnet_shadewall(l) = lwnet_shadewall(l) - shadewall_a(l) - - ! step (3) - - improad_r_sky(l) = improad_r(l) * vf_sr(l) - improad_r_sunwall(l) = improad_r(l) * vf_wr(l) - improad_r_shadewall(l) = improad_r(l) * vf_wr(l) - - perroad_r_sky(l) = perroad_r(l) * vf_sr(l) - perroad_r_sunwall(l) = perroad_r(l) * vf_wr(l) - perroad_r_shadewall(l) = perroad_r(l) * vf_wr(l) - - road_r_sky(l) = road_r(l) * vf_sr(l) - road_r_sunwall(l) = road_r(l) * vf_wr(l) - road_r_shadewall(l) = road_r(l) * vf_wr(l) - - sunwall_r_sky(l) = sunwall_r(l) * vf_sw(l) - sunwall_r_road(l) = sunwall_r(l) * vf_rw(l) - sunwall_r_shadewall(l) = sunwall_r(l) * vf_ww(l) - - shadewall_r_sky(l) = shadewall_r(l) * vf_sw(l) - shadewall_r_road(l) = shadewall_r(l) * vf_rw(l) - shadewall_r_sunwall(l) = shadewall_r(l) * vf_ww(l) - - ! step (4) - - lwup_improad(l) = lwup_improad(l) + improad_r_sky(l) - lwup_perroad(l) = lwup_perroad(l) + perroad_r_sky(l) - lwup_sunwall(l) = lwup_sunwall(l) + sunwall_r_sky(l) - lwup_shadewall(l) = lwup_shadewall(l) + shadewall_r_sky(l) - - ! step (5) - - crit = max(road_a(l), sunwall_a(l), shadewall_a(l)) - if (crit < .001_r8) exit - end do - if (iter >= n) then + do iter = 1, n + ! step (1) + + lwtot = (sunwall_r_road + sunwall_e_road & + + shadewall_r_road + shadewall_e_road )*canyon_hwr + road_a = 0.0_r8 + road_r = 0.0_r8 + improad_r = (1._r8-em_improad ) * lwtot + improad_a = em_improad * lwtot + road_a = road_a + improad_a *wtroad_imperv + road_r = road_r + improad_r *wtroad_imperv + perroad_r = (1._r8-em_perroad ) * lwtot + perroad_a = em_perroad * lwtot + road_a = road_a + perroad_a *wtroad_perv + road_r = road_r + perroad_r *wtroad_perv + + lwtot = (road_r_sunwall + road_e_sunwall )/canyon_hwr & + + (shadewall_r_sunwall + shadewall_e_sunwall ) + sunwall_a = em_wall * lwtot + sunwall_r = (1._r8-em_wall ) * lwtot + + lwtot = (road_r_shadewall + road_e_shadewall )/canyon_hwr & + + (sunwall_r_shadewall + sunwall_e_shadewall ) + shadewall_a = em_wall * lwtot + shadewall_r = (1._r8-em_wall ) * lwtot + + sunwall_e_road = 0._r8 + shadewall_e_road = 0._r8 + road_e_sunwall = 0._r8 + shadewall_e_sunwall = 0._r8 + road_e_shadewall = 0._r8 + sunwall_e_shadewall = 0._r8 + + ! step (2) + + lwnet_improad = lwnet_improad - improad_a + lwnet_perroad = lwnet_perroad - perroad_a + lwnet_sunwall = lwnet_sunwall - sunwall_a + lwnet_shadewall = lwnet_shadewall - shadewall_a + + ! step (3) + + improad_r_sky = improad_r * vf_sr + improad_r_sunwall = improad_r * vf_wr + improad_r_shadewall = improad_r * vf_wr + + perroad_r_sky = perroad_r * vf_sr + perroad_r_sunwall = perroad_r * vf_wr + perroad_r_shadewall = perroad_r * vf_wr + + road_r_sky = road_r * vf_sr + road_r_sunwall = road_r * vf_wr + road_r_shadewall = road_r * vf_wr + + sunwall_r_sky = sunwall_r * vf_sw + sunwall_r_road = sunwall_r * vf_rw + sunwall_r_shadewall = sunwall_r * vf_ww + + shadewall_r_sky = shadewall_r * vf_sw + shadewall_r_road = shadewall_r * vf_rw + shadewall_r_sunwall = shadewall_r * vf_ww + + ! step (4) + + lwup_improad = lwup_improad + improad_r_sky + lwup_perroad = lwup_perroad + perroad_r_sky + lwup_sunwall = lwup_sunwall + sunwall_r_sky + lwup_shadewall = lwup_shadewall + shadewall_r_sky + + ! step (5) + + crit = max(road_a, sunwall_a, shadewall_a) + if (crit < .001_r8) exit + end do + + if (iter >= n) then #ifndef _OPENACC - write (iulog,*) 'urban net longwave radiation error: no convergence' - write (iulog,*) 'elm model is stopping' - call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + write (iulog,*) 'urban net longwave radiation error: no convergence' + write (iulog,*) 'elm model is stopping' + call endrun() #endif - endif + endif ! total net longwave radiation for canyon. project wall fluxes to horizontal surface - lwnet_canyon(l) = 0.0_r8 - lwnet_canyon(l) = lwnet_canyon(l) + lwnet_improad(l)*wtroad_imperv(l) - lwnet_canyon(l) = lwnet_canyon(l) + lwnet_perroad(l)*wtroad_perv(l) - lwnet_canyon(l) = lwnet_canyon(l) + (lwnet_sunwall(l) + lwnet_shadewall(l))*canyon_hwr(l) + lwnet_canyon = 0.0_r8 + lwnet_canyon = lwnet_canyon + lwnet_improad*wtroad_imperv + lwnet_canyon = lwnet_canyon + lwnet_perroad*wtroad_perv + lwnet_canyon = lwnet_canyon + (lwnet_sunwall + lwnet_shadewall)*canyon_hwr ! total emitted longwave for canyon. project wall fluxes to horizontal - lwup_canyon(l) = 0.0_r8 - lwup_canyon(l) = lwup_canyon(l) + lwup_improad(l)*wtroad_imperv(l) - lwup_canyon(l) = lwup_canyon(l) + lwup_perroad(l)*wtroad_perv(l) - lwup_canyon(l) = lwup_canyon(l) + (lwup_sunwall(l) + lwup_shadewall(l))*canyon_hwr(l) + lwup_canyon = 0.0_r8 + lwup_canyon = lwup_canyon + lwup_improad*wtroad_imperv + lwup_canyon = lwup_canyon + lwup_perroad*wtroad_perv + lwup_canyon = lwup_canyon + (lwup_sunwall + lwup_shadewall)*canyon_hwr ! conservation check. note: previous conservation check confirms partioning of incident ! atmospheric longwave radiation to road and walls is conserved as ! lwdown (from atmosphere) = lwdown_improad + lwdown_perroad + (lwdown_sunwall + lwdown_shadewall)*canyon_hwr - err = lwnet_canyon(l) - (lwup_canyon(l) - lwdown(l)) + err = lwnet_canyon - (lwup_canyon - lwdown) if (abs(err) > .10_r8 ) then #ifndef _OPENACC write (iulog,*) 'urban net longwave radiation balance error',err write (iulog,*) 'elm model is stopping' - call endrun(decomp_index=l, elmlevel=namel, msg=errmsg(__FILE__, __LINE__)) + call endrun() #endif end if - end do - ! Net longwave radiation for roof - do fl = 1,num_urbanl - l = filter_urbanl(fl) - lwup_roof(l) = em_roof(l)*sb*(t_roof(l)**4) + (1._r8-em_roof(l))*lwdown(l) - lwnet_roof(l) = lwup_roof(l) - lwdown(l) - end do - - end associate + lwup_roof = em_roof*sb*(t_roof**4) + (1._r8-em_roof)*lwdown + lwnet_roof = lwup_roof - lwdown end subroutine net_longwave diff --git a/components/elm/src/biogeophys/lapack_acc_seq.F90 b/components/elm/src/biogeophys/lapack_acc_seq.F90 new file mode 100644 index 000000000000..aeb3ba094620 --- /dev/null +++ b/components/elm/src/biogeophys/lapack_acc_seq.F90 @@ -0,0 +1,806 @@ +module lapack_acc_seq + !! This module contains the needed LAPACK/BLAS routines that need + !! to be called on the GPU. As of CUDA 10.1, cuBLAS being called in + !! device code is no longer supported + +contains + +INTEGER FUNCTION idamax(N,DX,INCX) + !$acc routine seq + !* + !* -- Reference BLAS level1 routine (version 3.8.0) -- + !* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + !* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + !* November 2017 + !* + !* .. Scalar Arguments .. + INTEGER incx,n + !* .. + !* .. Array Arguments .. + DOUBLE PRECISION dx(*) + !* .. + !* + !* ===================================================================== + !* + !* .. Local Scalars .. + DOUBLE PRECISION dmax + INTEGER i,ix + !* .. + !* .. Intrinsic Functions .. + INTRINSIC dabs + !* .. + idamax = 0 + IF (n.LT.1 .OR. incx.LE.0) RETURN + idamax = 1 + IF (n.EQ.1) RETURN + IF (incx.EQ.1) THEN + ! + ! code for increment equal to 1 + ! + dmax = dabs(dx(1)) + DO i = 2,n + IF (dabs(dx(i)).GT.dmax) THEN + idamax = i + dmax = dabs(dx(i)) + END IF + END DO + ELSE + ! + ! code for increment not equal to 1 + ! + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + DO i = 2,n + IF (dabs(dx(ix)).GT.dmax) THEN + idamax = i + dmax = dabs(dx(ix)) + END IF + ix = ix + incx + END DO + END IF + RETURN +END FUNCTION idamax + + subroutine dswap_oacc(N,DX,INCX,DY,INCY) + !$acc routine seq + !* + !* -- Reference BLAS level1 routine (version 3.8.0) -- + !* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + !* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + !* November 2017 + !* + !* .. Scalar Arguments .. + INTEGER INCX,INCY,N + !* .. + !* .. Array Arguments .. + DOUBLE PRECISION DX(*),DY(*) + !* .. + !* + !* ===================================================================== + !* + !* .. Local Scalars .. + DOUBLE PRECISION DTEMP + INTEGER I,IX,IY,M,MP1 + !* .. + !* .. Intrinsic Functions .. + INTRINSIC mod + !* .. + IF (n.LE.0) RETURN + IF (incx.EQ.1 .AND. incy.EQ.1) THEN + !* + !* code for both increments equal to 1 + !* + !* + !* clean-up loop + !* + m = mod(n,3) + IF (m.NE.0) THEN + DO i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + END DO + IF (n.LT.3) RETURN + END IF + mp1 = m + 1 + DO i = mp1,n,3 + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + dtemp = dx(i+1) + dx(i+1) = dy(i+1) + dy(i+1) = dtemp + dtemp = dx(i+2) + dx(i+2) = dy(i+2) + dy(i+2) = dtemp + END DO + ELSE + !* + !* code for unequal increments or equal increments not equal + !* to 1 + !* + ix = 1 + iy = 1 + IF (incx.LT.0) ix = (-n+1)*incx + 1 + IF (incy.LT.0) iy = (-n+1)*incy + 1 + DO i = 1,n + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + END DO + END IF + RETURN + end subroutine dswap_oacc + + subroutine dscal_oacc(N,DA,DX,INCX) + !$acc routine seq + !* + !* -- Reference BLAS level1 routine (version 3.8.0) -- + !* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + !* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + !* November 2017 + !* + !* .. Scalar Arguments .. + DOUBLE PRECISION DA + INTEGER INCX,N + !* .. + !* .. Array Arguments .. + DOUBLE PRECISION DX(*) + !* .. + !* + !* ===================================================================== + !* + !* .. Local Scalars .. + INTEGER I,M,MP1,NINCX + !* .. + !* .. Intrinsic Functions .. + INTRINSIC mod + !* .. + IF (n.LE.0 .OR. incx.LE.0) RETURN + IF (incx.EQ.1) THEN + !* + !* code for increment equal to 1 + !* + !* + !* clean-up loop + !* + m = mod(n,5) + IF (m.NE.0) THEN + DO i = 1,m + dx(i) = da*dx(i) + END DO + IF (n.LT.5) RETURN + END IF + mp1 = m + 1 + DO i = mp1,n,5 + dx(i) = da*dx(i) + dx(i+1) = da*dx(i+1) + dx(i+2) = da*dx(i+2) + dx(i+3) = da*dx(i+3) + dx(i+4) = da*dx(i+4) + END DO + ELSE + !* + !* code for increment not equal to 1 + !* + nincx = n*incx + DO i = 1,nincx,incx + dx(i) = da*dx(i) + END DO + END IF + RETURN + end subroutine dscal_oacc + + subroutine dger_oacc(M,N,ALPHA,X,INCX,Y,INCY,A,LDA) + !$acc routine seq + !* + !* -- Reference BLAS level2 routine (version 3.7.0) -- + !* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + !* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + !* December 2016 + !* + !* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA + INTEGER INCX,INCY,LDA,M,N + !* .. + !* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*),Y(*) + !* .. + !* + !* ===================================================================== + !* + !* .. Parameters .. + DOUBLE PRECISION ZERO + parameter(zero=0.0d+0) + !* .. + !* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JY,KX + !* .. + !* .. Intrinsic Functions .. + INTRINSIC max + !* .. + !* + !* Test the input parameters. + !* + info = 0 + IF (m.LT.0) THEN + info = 1 + ELSE IF (n.LT.0) THEN + info = 2 + ELSE IF (incx.EQ.0) THEN + info = 5 + ELSE IF (incy.EQ.0) THEN + info = 7 + ELSE IF (lda.LT.max(1,m)) THEN + info = 9 + END IF + IF (info.NE.0) THEN + print *,"ERROR",info + RETURN + END IF + !* + !* Quick return if possible. + !* + IF ((m.EQ.0) .OR. (n.EQ.0) .OR. (alpha.EQ.zero)) RETURN + !* + !* Start the operations. In this version the elements of A are + !* accessed sequentially with one pass through A. + !* + IF (incy.GT.0) THEN + jy = 1 + ELSE + jy = 1 - (n-1)*incy + END IF + IF (incx.EQ.1) THEN + DO 20 j = 1,n + IF (y(jy).NE.zero) THEN + temp = alpha*y(jy) + DO 10 i = 1,m + a(i,j) = a(i,j) + x(i)*temp +10 CONTINUE + END IF + jy = jy + incy +20 CONTINUE + ELSE + IF (incx.GT.0) THEN + kx = 1 + ELSE + kx = 1 - (m-1)*incx + END IF + DO 40 j = 1,n + IF (y(jy).NE.zero) THEN + temp = alpha*y(jy) + ix = kx + DO 30 i = 1,m + a(i,j) = a(i,j) + x(ix)*temp + ix = ix + incx +30 CONTINUE + END IF + jy = jy + incy +40 CONTINUE + END IF + !* + RETURN + !* + !* End of DGER . + !* + end subroutine dger_oacc + +SUBROUTINE dgbtf2_oacc( M, N, KL, KU, AB, LDAB, IPIV, INFO ) + !$acc routine seq + ! -- LAPACK computational routine (version 3.7.0) -- + ! -- LAPACK is a software package provided by Univ. of Tennessee, -- + ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + ! December 2016 + ! + ! .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, M, N + ! .. + ! .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ) + ! .. + ! + ! ===================================================================== + ! + ! .. Parameters .. + DOUBLE PRECISION ONE, ZERO + parameter( one = 1.0d+0, zero = 0.0d+0 ) + ! .. + ! .. Local Scalars .. + INTEGER I, J, JP, JU, KM, KV + ! .. + ! .. External Functions .. + !INTEGER IDAMAX + !EXTERNAL idamax + ! .. + ! .. External Subroutines .. + !EXTERNAL dger, dscal, dswap + ! .. + ! .. Intrinsic Functions .. + INTRINSIC max, min + ! .. + ! .. Executable Statements .. + ! + ! KV is the number of superdiagonals in the factor U, allowing for + ! fill-in. + ! + kv = ku + kl + ! + ! Test the input parameters. + ! + info = 0 + IF( m.LT.0 ) THEN + info = -1 + ELSE IF( n.LT.0 ) THEN + info = -2 + ELSE IF( kl.LT.0 ) THEN + info = -3 + ELSE IF( ku.LT.0 ) THEN + info = -4 + ELSE IF( ldab.LT.kl+kv+1 ) THEN + info = -6 + END IF + IF( info.NE.0 ) THEN + print *, info, "error in " + RETURN + END IF + ! + ! Quick return if possible + ! + IF( m.EQ.0 .OR. n.EQ.0 ) RETURN + ! + ! Gaussian elimination with partial pivoting + ! + ! Set fill-in elements in columns KU+2 to KV to zero. + ! + DO 20 j = ku + 2, min( kv, n ) + DO 10 i = kv - j + 2, kl + ab( i, j ) = zero +10 CONTINUE +20 CONTINUE + ! + ! JU is the index of the last column affected by the current stage + ! of the factorization. + ! + ju = 1 + ! + DO 40 j = 1, min( m, n ) + ! + ! Set fill-in elements in column J+KV to zero. + ! + IF( j+kv.LE.n ) THEN + DO 30 i = 1, kl + ab( i, j+kv ) = zero +30 CONTINUE + END IF + ! + ! Find pivot and test for singularity. KM is the number of + ! subdiagonal elements in the current column. + ! + km = min( kl, m-j ) + jp = idamax( km+1, ab( kv+1, j ), 1 ) + ipiv( j ) = jp + j - 1 + IF( ab( kv+jp, j ).NE.zero ) THEN + ju = max( ju, min( j+ku+jp-1, n ) ) + ! + ! Apply interchange to columns J to JU. + ! + IF( jp.NE.1 ) & + CALL dswap_oacc( ju-j+1, ab( kv+jp, j ), ldab-1, & + ab( kv+1, j ), ldab-1 ) + + IF( km.GT.0 ) THEN + ! + ! Compute multipliers. + ! + CALL dscal_oacc( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) + ! + ! Update trailing submatrix within the band. + ! + IF( ju.GT.j ) & + CALL dger_oacc( km, ju-j, -one, ab( kv+2, j ), 1, & + ab( kv, j+1 ), ldab-1, ab( kv+1, j+1 ), & + ldab-1 ) + END IF + ELSE + ! + ! If pivot is zero, set INFO to the index of the pivot + ! unless a zero pivot has already been found. + ! + IF( info.EQ.0 ) info = j + + END IF +40 CONTINUE + RETURN +! +! End of DGBTF2 +! +END SUBROUTINE DGBTF2_oacc + +SUBROUTINE dgbtrf_oacc( M, N, KL, KU, AB, LDAB, IPIV, INFO ) +!$acc routine seq +! -- LAPACK computational routine (version 3.7.0) -- +! -- LAPACK is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! December 2016 +! +! .. Scalar Arguments .. +INTEGER INFO, KL, KU, LDAB, M, N +! .. +! .. Array Arguments .. +INTEGER IPIV( * ) +DOUBLE PRECISION AB( LDAB, * ) +! .. +! +! ===================================================================== +! +! .. Parameters .. +DOUBLE PRECISION ONE, ZERO +parameter( one = 1.0d+0, zero = 0.0d+0 ) +INTEGER NBMAX, LDWORK +parameter( nbmax = 64, ldwork = nbmax+1 ) +! .. +! .. Local Scalars .. +INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, & + JU, K2, KM, KV, NB, NW +DOUBLE PRECISION TEMP +! .. +! .. Local Arrays .. +DOUBLE PRECISION WORK13( LDWORK, NBMAX ), & + WORK31( LDWORK, NBMAX ) +! .. +! .. External Functions .. +!INTEGER IDAMAX !, ILAENV +!EXTERNAL idamax !, ilaenv +! .. +! .. External Subroutines .. +!EXTERNAL dgbtf2, dger, dscal, dswap +! .. +! .. Intrinsic Functions .. +INTRINSIC max, min +! .. +! .. Executable Statements .. +! +! KV is the number of superdiagonals in the factor U, allowing for +! fill-in +! +kv = ku + kl +! +! Test the input parameters. +! +info = 0 +IF( m.LT.0 ) THEN + info = -1 +ELSE IF( n.LT.0 ) THEN + info = -2 +ELSE IF( kl.LT.0 ) THEN + info = -3 +ELSE IF( ku.LT.0 ) THEN + info = -4 +ELSE IF( ldab.LT.kl+kv+1 ) THEN + info = -6 +END IF +IF( info.NE.0 ) THEN + print *, "error in dgbtrf", info + RETURN +END IF +! +! Quick return if possible +! +IF( m.EQ.0 .OR. n.EQ.0 ) RETURN +! +! Determine the block size for this environment +! +!nb = ilaenv( 1, 'DGBTRF', ' ', m, n, kl, ku ) +! +! The block size must not exceed the limit set by the size of the +! local arrays WORK13 and WORK31. +! +! +! Use unblocked code +! + CALL dgbtf2_oacc( m, n, kl, ku, ab, ldab, ipiv, info ) + +! +RETURN +! +! End of DGBTRF +! +END subroutine dgbtrf_oacc + + +SUBROUTINE dtbsv_oacc(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX) + !$acc routine seq + !NOTE : FOR DGBTRS WE HARDCODE UPLO='UPPER',TRANS='NO TRANSPOSE',DIAG='NON-UNIT' + !* + !* -- Reference BLAS level2 routine (version 3.7.0) -- + !* -- Reference BLAS is a software package provided by Univ. of Tennessee, -- + !* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + !* December 2016 + !* + !* .. Scalar Arguments .. + INTEGER INCX,K,LDA,N + INTEGER DIAG,TRANS,UPLO + !* .. + !* .. Array Arguments .. + DOUBLE PRECISION A(LDA,*),X(*) + !* .. + !* + !* ===================================================================== + !* + !* .. Parameters .. + DOUBLE PRECISION ZERO + parameter(zero=0.0d+0) + !* .. + !* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L + LOGICAL NOUNIT + !* .. + !* .. External Subroutines .. + !* .. + !* .. Intrinsic Functions .. + INTRINSIC max,min + !* .. + !* + !* Test the input parameters. + !* + info = 0 + IF (uplo .ne. 1 ) THEN + info = 1 + ELSE IF (trans .ne. 0 ) THEN + info = 2 + ELSE IF (diag .ne. 0) THEN + info = 3 + ELSE IF (n.LT.0) THEN + info = 4 + ELSE IF (k.LT.0) THEN + info = 5 + ELSE IF (lda.LT. (k+1)) THEN + info = 7 + ELSE IF (incx.EQ.0) THEN + info = 9 + END IF + IF (info.NE.0) THEN + print *, "ERRROR in dtbsv", info + RETURN + END IF + !* + !* Quick return if possible. + !* + IF (n.EQ.0) RETURN + !* + nounit = .true. + !* + !* Set up the start point in X if the increment is not unity. This + !* will be ( N - 1 )*INCX too small for descending loops. + !* + IF (incx.LE.0) THEN + kx = 1 - (n-1)*incx + ELSE IF (incx.NE.1) THEN + kx = 1 + END IF + !* + !* Start the operations. In this version the elements of A are + !* accessed by sequentially with one pass through A. + !* + !* + !* Form x := inv( A )*x. + !* + kplus1 = k + 1 + IF (incx.EQ.1) THEN + DO 20 j = n,1,-1 + IF (x(j).NE.zero) THEN + l = kplus1 - j + IF (nounit) x(j) = x(j)/a(kplus1,j) + temp = x(j) + DO 10 i = j - 1,max(1,j-k),-1 + x(i) = x(i) - temp*a(l+i,j) +10 CONTINUE + END IF +20 CONTINUE + ELSE + kx = kx + (n-1)*incx + jx = kx + DO 40 j = n,1,-1 + kx = kx - incx + IF (x(jx).NE.zero) THEN + ix = kx + l = kplus1 - j + IF (nounit) x(jx) = x(jx)/a(kplus1,j) + temp = x(jx) + DO 30 i = j - 1,max(1,j-k),-1 + x(ix) = x(ix) - temp*a(l+i,j) + ix = ix - incx +30 CONTINUE + END IF + jx = jx - incx +40 CONTINUE + END IF + !* + RETURN + !* + !* End of DTBSV . + !* +END subroutine DTBSV_oacc + +SUBROUTINE dgbtrs_oacc( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) + !$acc routine seq + ! -- LAPACK computational routine (version 3.7.0) -- + ! -- LAPACK is a software package provided by Univ. of Tennessee, -- + ! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- + ! December 2016 + ! + ! .. Scalar Arguments .. + INTEGER TRANS + INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS + ! .. + ! .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) + ! .. + ! + ! ===================================================================== + ! + ! .. Parameters .. + DOUBLE PRECISION ONE + parameter( one = 1.0d+0 ) + ! .. + ! .. Local Scalars .. + LOGICAL LNOTI, NOTRAN + INTEGER I, J, KD, L, LM + !* .. + !* .. External Functions .. + !LOGICAL LSAME + !EXTERNAL lsame + !* .. + !* .. External Subroutines .. + !EXTERNAL dgemv, dger, dswap, dtbsv + !* .. + !* .. Intrinsic Functions .. + INTRINSIC max, min + !* .. + !* .. Executable Statements .. + !* + !* Test the input parameters. + !* + info = 0 + notran = .true. + IF( .NOT.notran ) THEN + info = -1 + ELSE IF( n.LT.0 ) THEN + info = -2 + ELSE IF( kl.LT.0 ) THEN + info = -3 + ELSE IF( ku.LT.0 ) THEN + info = -4 + ELSE IF( nrhs.LT.0 ) THEN + info = -5 + ELSE IF( ldab.LT.( 2*kl+ku+1 ) ) THEN + info = -7 + ELSE IF( ldb.LT.max( 1, n ) ) THEN + info = -10 + END IF + IF( info.NE.0 ) THEN + print *,"error in solving Ax=b",info + RETURN + END IF + ! + ! Quick return if possible + ! + IF( n.EQ.0 .OR. nrhs.EQ.0 ) RETURN + ! + kd = ku + kl + 1 + lnoti = kl.GT.0 + ! + IF( notran ) THEN + !* + !* Solve A*X = B. + !* + !* Solve L*X = B, overwriting B with X. + !* + !* L is represented as a product of permutations and unit lower + !* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), + !* where each transformation L(i) is a rank-one modification of + !* the identity matrix. + !* + IF( lnoti ) THEN + DO 10 j = 1, n - 1 + lm = min( kl, n-j ) + l = ipiv( j ) + IF( l.NE.j ) CALL dswap_oacc( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) + + CALL dger_oacc( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ), & + ldb, b( j+1, 1 ), ldb ) +10 CONTINUE + END IF + ! + DO 20 i = 1, nrhs + !* + !* Solve U*X = B, overwriting B with X. + !* + CALL dtbsv_oacc( 1, 0, 0, n, kl+ku, & + ab, ldab, b( 1, i ), 1 ) +20 CONTINUE + !! + END IF + RETURN + !* + !* End of DGBTRS + !* + END subroutine DGBTRS_oacc + + + +subroutine dgbsv_oacc( N, KL, KU, NRHS, AB, LDAB, B, LDB, INFO ) +!$acc routine seq +! -- LAPACK driver routine (version 3.7.0) -- +! -- LAPACK is a software package provided by Univ. of Tennessee, -- +! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +! December 2016 +! +! .. Scalar Arguments .. + INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS +!* .. +!* .. Array Arguments .. + DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) +! .. +! +! ===================================================================== +! +! .. External Subroutines .. +! EXTERNAL dgbtrf, dgbtrs +! .. +! .. Intrinsic Functions .. + INTRINSIC max + INTEGER :: IPIV(1:n) +! .. +! .. Executable Statements .. +! +! Test the input parameters. +! + info = 0 + IF( n.LT.0 ) THEN + info = -1 + ELSE IF( kl.LT.0 ) THEN + info = -2 + ELSE IF( ku.LT.0 ) THEN + info = -3 + ELSE IF( nrhs.LT.0 ) THEN + info = -4 + ELSE IF( ldab.LT.2*kl+ku+1 ) THEN + info = -6 + ELSE IF( ldb.LT.max( n, 1 ) ) THEN + info = -9 + END IF + IF( info.NE.0 ) THEN + print *,"error in dgbsv",info + RETURN + END IF +! +! Compute the LU factorization of the band matrix A. +! + CALL dgbtrf_oacc( n, n, kl, ku, ab, ldab, ipiv, info ) + IF( info.EQ.0 ) THEN +! +! Solve the system A*X = B, overwriting B with X. +! I changed the first argument from 'No transpose' to 0 + CALL dgbtrs_oacc( 0, n, kl, ku, nrhs, ab, ldab, ipiv, & + b, ldb, info ) + else + print *,"error: dgbsv",info + + END IF + RETURN +! +! End of DGBSV +! +END subroutine dgbsv_oacc + + +end module lapack_acc_seq