From 074c1b0516db67b9f56dacb0d300fe2d4ecb8c70 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Sep 2021 09:44:03 -0600 Subject: [PATCH 1/9] Make vegetation, slope and soil type integers --- physics/GFS_debug.F90 | 52 ++++------ physics/GFS_debug.meta | 37 +------ physics/GFS_phys_time_vary.fv3.F90 | 11 +- physics/GFS_phys_time_vary.fv3.meta | 25 ++--- physics/GFS_phys_time_vary.scm.F90 | 5 +- physics/GFS_phys_time_vary.scm.meta | 10 +- physics/GFS_radiation_surface.F90 | 8 +- physics/GFS_radiation_surface.meta | 9 -- physics/GFS_surface_generic.F90 | 85 ++++++++++++---- physics/GFS_surface_generic.meta | 124 ++++++++++++++++------- physics/gcycle.F90 | 22 +++- physics/radiation_surface.f | 3 +- physics/sfc_drv_ruc.F90 | 92 +++++++---------- physics/sfc_drv_ruc.meta | 18 ++-- physics/sfc_noah_wrfv4_interstitial.F90 | 5 +- physics/sfc_noah_wrfv4_interstitial.meta | 5 +- 16 files changed, 275 insertions(+), 236 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 43f48dfed..2de372e59 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1309,14 +1309,12 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmaf ', Interstitial%sigmaf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slopetype ', Interstitial%slopetype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_water ', Interstitial%snowd_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%soiltype ', Interstitial%soiltype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_ice ', Interstitial%stress_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_land ', Interstitial%stress_land ) @@ -1344,7 +1342,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_water ', Interstitial%uustar_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegtype ', Interstitial%vegtype ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) @@ -1551,8 +1548,7 @@ end subroutine GFS_checkland_finalize !! subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & - soiltyp, vegtype, slopetyp, dry, icy, wet, lake, ocean, & - oceanfrac, landfrac, lakefrac, slmsk, islmsk, & + dry, icy, wet, lake, ocean, oceanfrac, landfrac, lakefrac, slmsk, islmsk, & zorl, zorlw, zorll, zorli, fice, errmsg, errflg ) use machine, only: kind_phys @@ -1566,34 +1562,31 @@ subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_ integer, intent(in ) :: im integer, intent(in ) :: kdt integer, intent(in ) :: iter - logical, intent(in ) :: flag_iter(im) - logical, intent(in ) :: flag_guess(im) + logical, intent(in ) :: flag_iter(:) + logical, intent(in ) :: flag_guess(:) logical, intent(in ) :: flag_init logical, intent(in ) :: flag_restart logical, intent(in ) :: frac_grid integer, intent(in ) :: isot integer, intent(in ) :: ivegsrc - real(kind_phys), intent(in ) :: stype(im) - real(kind_phys), intent(in ) :: vtype(im) - real(kind_phys), intent(in ) :: slope(im) - integer, intent(in ) :: soiltyp(im) - integer, intent(in ) :: vegtype(im) - integer, intent(in ) :: slopetyp(im) - logical, intent(in ) :: dry(im) - logical, intent(in ) :: icy(im) - logical, intent(in ) :: wet(im) - logical, intent(in ) :: lake(im) - logical, intent(in ) :: ocean(im) - real(kind_phys), intent(in ) :: oceanfrac(im) - real(kind_phys), intent(in ) :: landfrac(im) - real(kind_phys), intent(in ) :: lakefrac(im) - real(kind_phys), intent(in ) :: slmsk(im) - integer, intent(in ) :: islmsk(im) - real(kind_phys), intent(in ) :: zorl(im) - real(kind_phys), intent(in ) :: zorlw(im) - real(kind_phys), intent(in ) :: zorll(im) - real(kind_phys), intent(in ) :: zorli(im) - real(kind_phys), intent(in ) :: fice(im) + integer, intent(in ) :: stype(:) + integer, intent(in ) :: vtype(:) + integer, intent(in ) :: slope(:) + logical, intent(in ) :: dry(:) + logical, intent(in ) :: icy(:) + logical, intent(in ) :: wet(:) + logical, intent(in ) :: lake(:) + logical, intent(in ) :: ocean(:) + real(kind_phys), intent(in ) :: oceanfrac(:) + real(kind_phys), intent(in ) :: landfrac(:) + real(kind_phys), intent(in ) :: lakefrac(:) + real(kind_phys), intent(in ) :: slmsk(:) + integer, intent(in ) :: islmsk(:) + real(kind_phys), intent(in ) :: zorl(:) + real(kind_phys), intent(in ) :: zorlw(:) + real(kind_phys), intent(in ) :: zorll(:) + real(kind_phys), intent(in ) :: zorli(:) + real(kind_phys), intent(in ) :: fice(:) character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -1623,9 +1616,6 @@ subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_ write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, soiltyp(i) :', i, blkno, soiltyp(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, vegtype(i) :', i, blkno, vegtype(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, slopetyp(i) :', i, blkno, slopetyp(i) write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, icy(i) :', i, blkno, icy(i) write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, wet(i) :', i, blkno, wet(i) diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 4615e163a..fb77772eb 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -604,51 +604,24 @@ intent = in optional = F [stype] - standard_name = soil_type_classification_real - long_name = soil type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[vtype] - standard_name = vegetation_type_classification_real - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[slope] - standard_name = surface_slope_classification_real - long_name = sfc slope type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[soiltyp] standard_name = soil_type_classification - long_name = soil type at each grid cell + long_name = soil type for lsm units = index dimensions = (horizontal_loop_extent) type = integer intent = in optional = F -[vegtype] +[vtype] standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell + long_name = vegetation type for lsm units = index dimensions = (horizontal_loop_extent) type = integer intent = in optional = F -[slopetyp] +[slope] standard_name = surface_slope_classification - long_name = surface slope type at each grid cell + long_name = sfc slope type for lsm units = index dimensions = (horizontal_loop_extent) type = integer diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index 20c6c68c3..a8ecc1a5e 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -105,9 +105,9 @@ subroutine GFS_phys_time_vary_init ( integer, intent(in) :: isot, ivegsrc, nlunit real(kind_phys), intent(inout) :: sncovr(:), sncovr_ice(:) - integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc + integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, vtype(:) real(kind_phys), intent(in) :: min_seaice, fice(:) - real(kind_phys), intent(in) :: landfrac(:), vtype(:) + real(kind_phys), intent(in) :: landfrac(:) real(kind_phys), intent(inout) :: weasd(:) ! NoahMP - only allocated when NoahMP is used @@ -165,7 +165,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: snowd(:) real(kind_phys), intent(in) :: canopy(:) real(kind_phys), intent(in) :: tg3(:) - real(kind_phys), intent(in) :: stype(:) + integer, intent(in) :: stype(:) real(kind_phys), intent(in) :: con_t0c integer, intent(in) :: nthrds @@ -765,9 +765,10 @@ subroutine GFS_phys_time_vary_timestep_init ( tslb(:,:), tiice(:,:), tg3(:), tref(:), & tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & facsf(:), facwf(:), alvsf(:), alvwf(:), alnsf(:), alnwf(:), & - zorli(:), zorll(:), zorlo(:), weasd(:), slope(:), snoalb(:), & - canopy(:), vfrac(:), vtype(:), stype(:), shdmin(:), shdmax(:), & + zorli(:), zorll(:), zorlo(:), weasd(:), snoalb(:), & + canopy(:), vfrac(:), shdmin(:), shdmax(:), & snowd(:), cv(:), cvb(:), cvt(:), oro(:), oro_uf(:), slmsk(:) + integer, intent(inout) :: vtype(:), stype(:), slope(:) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 3fb2473bd..979200a85 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -444,12 +444,11 @@ intent = in optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [weasd] @@ -963,12 +962,11 @@ intent = in optional = F [stype] - standard_name = soil_type_classification_real + standard_name = soil_type_classification long_name = soil type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [con_t0c] @@ -1863,12 +1861,11 @@ intent = inout optional = F [slope] - standard_name = surface_slope_classification_real + standard_name = surface_slope_classification long_name = sfc slope type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = inout optional = F [snoalb] @@ -1899,21 +1896,19 @@ intent = inout optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = inout optional = F [stype] - standard_name = soil_type_classification_real + standard_name = soil_type_classification long_name = soil type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = inout optional = F [shdmin] diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index e0f380276..b06e46cdc 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -101,7 +101,8 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(inout) :: sncovr(:), sncovr_ice(:) integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc real(kind_phys), intent(in) :: min_seaice, fice(:) - real(kind_phys), intent(in) :: landfrac(:), vtype(:) + real(kind_phys), intent(in) :: landfrac(:) + integer, intent(in) :: vtype(:) real(kind_phys), intent(inout) :: weasd(:) ! NoahMP - only allocated when NoahMP is used @@ -159,7 +160,7 @@ subroutine GFS_phys_time_vary_init ( real(kind_phys), intent(in) :: snowd(:) real(kind_phys), intent(in) :: canopy(:) real(kind_phys), intent(in) :: tg3(:) - real(kind_phys), intent(in) :: stype(:) + integer, intent(in) :: stype(:) real(kind_phys), intent(in) :: con_t0c integer, intent(in) :: nthrds diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 1dd03d6b7..a075e8d82 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -444,12 +444,11 @@ intent = in optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [weasd] @@ -963,12 +962,11 @@ intent = in optional = F [stype] - standard_name = soil_type_classification_real + standard_name = soil_type_classification long_name = soil type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [con_t0c] diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index 11703c23c..56aaf051d 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -57,7 +57,7 @@ end subroutine GFS_radiation_surface_init !! subroutine GFS_radiation_surface_run ( & im, frac_grid, lslwr, lsswr, lsm, lsm_noahmp, lsm_ruc, & - vtype, xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & + xlat, xlon, slmsk, lndp_type, n_var_lndp, sfc_alb_pert, & lndp_var_list, lndp_prt_list, landfrac, snowd, sncovr, & sncovr_ice, fice, zorl, hprime, tsfg, tsfa, tisfc, coszen, & min_seaice, min_lakeice, lakefrac, & @@ -78,9 +78,9 @@ subroutine GFS_radiation_surface_run ( & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc, lndp_type, n_var_lndp real(kind=kind_phys), intent(in) :: min_seaice, min_lakeice - real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, vtype, slmsk, & + real(kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, slmsk, & sfc_alb_pert, lndp_prt_list, & - landfrac, lakefrac, & + landfrac, lakefrac, & snowd, sncovr, & sncovr_ice, fice, zorl, & hprime, tsfg, tsfa, tisfc, & @@ -159,7 +159,7 @@ subroutine GFS_radiation_surface_run ( & if (lslwr) then !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. - call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, & + call setemis (lsm, lsm_noahmp, lsm_ruc, & frac_grid, xlon, xlat, slmsk, & ! frac_grid, min_seaice, xlon, xlat, slmsk, & snowd, sncovr, sncovr_ice, zorl, tsfg, tsfa, & diff --git a/physics/GFS_radiation_surface.meta b/physics/GFS_radiation_surface.meta index f021cfe4d..6b8fb1e18 100644 --- a/physics/GFS_radiation_surface.meta +++ b/physics/GFS_radiation_surface.meta @@ -118,15 +118,6 @@ type = integer intent = in optional = F -[vtype] - standard_name = vegetation_type_classification_real - long_name = vegetation type for lsm - units = index - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [xlat] standard_name = latitude long_name = latitude diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 1ec7ff784..0826f32b6 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -16,7 +16,57 @@ module GFS_surface_generic_pre contains - subroutine GFS_surface_generic_pre_init () +!> \section arg_table_GFS_surface_generic_pre_init Argument Table +!! \htmlinclude GFS_surface_generic_pre_init.html +!! + subroutine GFS_surface_generic_pre_init (im, slmsk, isot, ivegsrc, stype, vtype, slope, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: im, isot, ivegsrc + real(kind_phys), dimension(:), intent(in) :: slmsk + integer, dimension(:), intent(inout) :: vtype, stype, slope + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + do i=1,im + if (nint(slmsk(i)) == 2) then + if (isot == 1) then + stype(i) = 16 + else + stype(i) = 9 + endif + if (ivegsrc == 0 .or. ivegsrc == 4) then + vtype(i) = 24 + elseif (ivegsrc == 1) then + vtype(i) = 15 + elseif (ivegsrc == 2) then + vtype(i) = 13 + elseif (ivegsrc == 3 .or. ivegsrc == 5) then + vtype(i) = 15 + endif + slope(i) = 9 + else + ! DH* remove else block if not needed + !soiltyp(i) = int( stype(i)+0.5_kind_phys ) + !vegtype(i) = int( vtype(i)+0.5_kind_phys ) + !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp + !if (vegtype(i) < 1) vegtype(i) = 17 + !if (slopetyp(i) < 1) slopetyp(i) = 1 + ! *DH + endif + enddo + end subroutine GFS_surface_generic_pre_init subroutine GFS_surface_generic_pre_finalize() @@ -26,8 +76,7 @@ end subroutine GFS_surface_generic_pre_finalize !! \htmlinclude GFS_surface_generic_pre_run.html !! subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & - prsik_1, prslk_1, tsfc, phil, con_g, & - sigmaf, soiltyp, vegtype, slopetyp, work3, zlvl, & + prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, sfc_wts_inv, & @@ -41,10 +90,10 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Interface variables integer, intent(in) :: im, levs, isot, ivegsrc integer, dimension(:), intent(in) :: islmsk - integer, dimension(:), intent(inout) :: soiltyp, vegtype, slopetyp real(kind=kind_phys), intent(in) :: con_g - real(kind=kind_phys), dimension(:), intent(in) :: vfrac, stype, vtype, slope, prsik_1, prslk_1 + real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 + integer, dimension(:), intent(inout) :: vtype, stype, slope real(kind=kind_phys), dimension(:), intent(inout) :: tsfc real(kind=kind_phys), dimension(:,:), intent(in) :: phil @@ -131,26 +180,28 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then - soiltyp(i) = 16 + stype(i) = 16 else - soiltyp(i) = 9 + stype(i) = 9 endif if (ivegsrc == 0 .or. ivegsrc == 4) then - vegtype(i) = 24 + vtype(i) = 24 elseif (ivegsrc == 1) then - vegtype(i) = 15 + vtype(i) = 15 elseif (ivegsrc == 2) then - vegtype(i) = 13 + vtype(i) = 13 elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vegtype(i) = 15 + vtype(i) = 15 endif - slopetyp(i) = 9 + slope(i) = 9 else - soiltyp(i) = int( stype(i)+0.5_kind_phys ) - vegtype(i) = int( vtype(i)+0.5_kind_phys ) - slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp - if (vegtype(i) < 1) vegtype(i) = 17 - if (slopetyp(i) < 1) slopetyp(i) = 1 + ! DH* REMOVE else block if not needeed - create separate subroutine to be called by both init and run? + !soiltyp(i) = int( stype(i)+0.5_kind_phys ) + !vegtype(i) = int( vtype(i)+0.5_kind_phys ) + !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp + !if (vegtype(i) < 1) vegtype(i) = 17 + !if (slopetyp(i) < 1) slopetyp(i) = 1 + ! *DH endif work3(i) = prsik_1(i) / prslk_1(i) diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 54756c1b4..c7b24446a 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -3,6 +3,85 @@ type = scheme dependencies = machine.F,surface_perturbation.F90 +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_pre_init + type = scheme +[im] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in + optional = F +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_surface_generic_pre_run @@ -57,31 +136,28 @@ intent = in optional = F [stype] - standard_name = soil_type_classification_real + standard_name = soil_type_classification long_name = soil type for lsm units = index dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in + type = integer + intent = inout optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in + type = integer + intent = inout optional = F [slope] - standard_name = surface_slope_classification_real + standard_name = surface_slope_classification long_name = sfc slope type for lsm units = index dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in + type = integer + intent = inout optional = F [prsik_1] standard_name = surface_dimensionless_exner_function @@ -137,30 +213,6 @@ kind = kind_phys intent = inout optional = F -[soiltyp] - standard_name = soil_type_classification - long_name = soil type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[vegtype] - standard_name = vegetation_type_classification - long_name = vegetation type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F -[slopetyp] - standard_name = surface_slope_classification - long_name = surface slope type at each grid cell - units = index - dimensions = (horizontal_loop_extent) - type = integer - intent = inout - optional = F [work3] standard_name = ratio_of_exner_function_between_midlayer_and_interface_at_lowest_model_layer long_name = Exner function ratio bt midlayer and interface at 1st layer diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 608147c4b..5f4f959c6 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -60,12 +60,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, zorll(:), & zorlo(:), & weasd(:), & - slope(:), & snoalb(:), & canopy(:), & vfrac(:), & - vtype(:), & - stype(:), & shdmin(:), & shdmax(:), & snowd(:), & @@ -75,6 +72,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, oro(:), & oro_uf(:), & slmsk(:) + integer, intent(inout) :: vtype(:), & + stype(:), & + slope(:) integer, intent(in) :: imap(:), jmap(:) ! @@ -84,6 +84,9 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, real(kind=kind_io8) :: & slmskl (nx*ny), & slmskw (nx*ny), & + slpfcs (nx*ny), & + vegfcs (nx*ny), & + sltfcs (nx*ny), & TSFFCS (nx*ny), & ZORFCS (nx*ny), & AISFCS (nx*ny), & @@ -121,6 +124,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, else TSFFCS = tsfco end if +! integer to real/double precision + slpfcs = real(slope) + vegfcs = real(vtype) + sltfcs = real(stype) ! if (frac_grid) then do ix=1,npts @@ -217,10 +224,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, phour, xlat_d, xlon_d, slmskl, slmskw, & oro, oro_uf, use_ufo, nst_anl, & hice, fice, tisfc, snowd, slcfc1, & - shdmin, shdmax, slope, snoalb, tsffcs, & + shdmin, shdmax, slpfcs, snoalb, tsffcs, & weasd, zorfcs, albfc1, tg3, canopy, & smcfc1, stcfc1, slmsk, aisfcs, & - vfrac, vtype, stype, alffc1, cv, & + vfrac, vegfcs, sltfcs, alffc1, cv, & cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & min_ice, ialb, isot, ivegsrc, & @@ -235,6 +242,11 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, tsfc = TSFFCS tsfco = TSFFCS endif +! +! real/double precision to integer + slope = int(slpfcs) + vtype = int(vegfcs) + stype = int(sltfcs) ! do ix=1,npts zorll(ix) = ZORFCS(ix) diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index 750c54dd6..fed29526c 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -726,7 +726,7 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid, & ! --- inputs: + & ( lsm,lsm_noahmp,lsm_ruc,frac_grid, & ! --- inputs: & xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & ! & min_seaice,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & @@ -784,7 +784,6 @@ subroutine setemis & integer, intent(in) :: IMAX integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid - real (kind=kind_phys), dimension(:), intent(in) :: vtype ! real (kind=kind_phys), intent(in) :: min_seaice real (kind=kind_phys), dimension(:), intent(in) :: & diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f313f2fba..26e4f2905 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -62,8 +62,8 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys), dimension(:), intent(in) :: slmsk - real (kind=kind_phys), dimension(:), intent(in) :: stype - real (kind=kind_phys), dimension(:), intent(in) :: vtype + integer, dimension(:), intent(in) :: stype + integer, dimension(:), intent(in) :: vtype real (kind=kind_phys), dimension(:), intent(in) :: q1 real (kind=kind_phys), dimension(:), intent(in) :: prsl1 real (kind=kind_phys), dimension(:), intent(in) :: tsfc_lnd @@ -112,7 +112,6 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & real (kind=kind_phys) :: q0, qs1 integer :: ipr, i, k logical :: debug_print - integer, dimension(im) :: soiltyp, vegtype ! Initialize CCPP error handling variables errmsg = '' @@ -164,31 +163,10 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & pores (:) = maxsmc (:) resid (:) = drysmc (:) - soiltyp(:) = 0 - vegtype(:) = 0 - do i = 1, im ! i - horizontal loop - if (slmsk(i) == 2.) then - !-- ice - if (isot == 1) then - soiltyp(i) = 16 - else - soiltyp(i) = 9 - endif - if (ivegsrc == 1) then - vegtype(i) = 15 - elseif(ivegsrc == 2) then - vegtype(i) = 13 - endif - else - !-- land or water - soiltyp(i) = int( stype(i)+0.5 ) - vegtype(i) = int( vtype(i)+0.5 ) - if (soiltyp(i) < 1) soiltyp(i) = 14 - if (vegtype(i) < 1) vegtype(i) = 17 - endif + !-- initialize background emissivity - semisbase(i) = lemitbl(vegtype(i)) ! no snow effect + semisbase(i) = lemitbl(vtype(i)) ! no snow effect if (.not.flag_restart) then !-- land @@ -225,7 +203,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in + stype, vtype, & ! in tsfc_lnd, tsfc_wat, tg3, & ! in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out @@ -280,8 +258,8 @@ end subroutine lsm_ruc_finalize ! ps - real, surface pressure (pa) im ! ! t1 - real, surface layer mean temperature (k) im ! ! q1 - real, surface layer mean specific humidity im ! -! soiltyp - integer, soil type (integer index) im ! -! vegtype - integer, vegetation type (integer index) im ! +! stype - integer, soil type (integer index) im ! +! vtype - integer, vegetation type (integer index) im ! ! sigmaf - real, areal fractional cover of green vegetation im ! ! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! ! dswflx - real, total sky sfc downward sw flux ( w/m**2 ) im ! @@ -343,7 +321,7 @@ subroutine lsm_ruc_run & ! inputs & ( iter, me, master, delt, kdt, im, nlev, lsm_ruc, lsm, & & imp_physics, imp_physics_gfdl, imp_physics_thompson, & & do_mynnsfclay, lsoil_ruc, lsoil, rdlai, zs, & - & t1, q1, qc, soiltyp, vegtype, sigmaf, laixy, & + & t1, q1, qc, stype, vtype, sigmaf, laixy, & & dlwflx, dswsfc, tg3, coszen, land, icy, lake, & & rainnc, rainc, ice, snow, graupel, & & prsl1, zf, wind, shdmin, shdmax, & @@ -420,7 +398,8 @@ subroutine lsm_ruc_run & ! inputs logical, intent(in) :: rdlai ! --- in/out: - integer, dimension(:), intent(inout) :: soiltyp, vegtype + integer, dimension(:), intent(inout) :: stype + integer, dimension(:), intent(in) :: vtype real (kind=kind_phys), dimension(:), intent(in) :: zs real (kind=kind_phys), dimension(:), intent(in) :: srflag real (kind=kind_phys), dimension(:), intent(inout) :: & @@ -591,8 +570,8 @@ subroutine lsm_ruc_run & ! inputs if(debug_print) then write (0,*)'RUC LSM run' - write (0,*)'soiltyp=',ipr,soiltyp(ipr) - write (0,*)'vegtype=',ipr,vegtype(ipr) + write (0,*)'stype=',ipr,stype(ipr) + write (0,*)'vtype=',ipr,vtype(ipr) write (0,*)'kdt, iter =',kdt,iter write (0,*)'flag_init =',flag_init write (0,*)'flag_restart =',flag_restart @@ -655,8 +634,8 @@ subroutine lsm_ruc_run & ! inputs smcwlt2 (i) = 0. else !land - smcref2 (i) = REFSMC(soiltyp(i)) - smcwlt2 (i) = WLTSMC(soiltyp(i)) + smcref2 (i) = REFSMC(stype(i)) + smcwlt2 (i) = WLTSMC(stype(i)) endif enddo @@ -858,18 +837,18 @@ subroutine lsm_ruc_run & ! inputs tbot(i,j) = tg3(i) !> - 3. canopy/soil characteristics (s): -!!\n \a vegtyp - vegetation type (integer index) -> vtype -!!\n \a soiltyp - soil type (integer index) -> stype -!!\n \a sfcems - surface emmisivity -> sfcemis -!!\n \a sfalb_lnd_bck - backround snow-free surface albedo (fraction) -> albbck_lnd -!!\n \a snoalb - upper bound on maximum albedo over deep snow -> snoalb1d_lnd +!!\n \a vtype - vegetation type (integer index) +!!\n \a stype - soil type (integer index) +!!\n \a sfcems - surface emmisivity -> sfcemis +!!\n \a sfalb_lnd_bck - backround snow-free surface albedo (fraction) -> albbck_lnd +!!\n \a snoalb - upper bound on maximum albedo over deep snow -> snoalb1d_lnd if(ivegsrc == 1) then ! IGBP - MODIS vtype_wat(i,j) = 17 ! 17 - water (oceans and lakes) in MODIS stype_wat(i,j) = 14 xland_wat(i,j) = 2. ! xland = 2 for water - vtype_lnd(i,j) = vegtype(i) - stype_lnd(i,j) = soiltyp(i) + vtype_lnd(i,j) = vtype(i) + stype_lnd(i,j) = stype(i) vtype_ice(i,j) = 15 ! MODIS if(isot == 0) then stype_ice(i,j) = 9 ! ZOBLER @@ -936,7 +915,7 @@ subroutine lsm_ruc_run & ! inputs if(coszen(i) > 0. .and. weasd_lnd(i) < 1.e-4) then !-- solar zenith angle dependence when no snow - ilst=istwe(vegtype(i)) ! 1 or 2 + ilst=istwe(vtype(i)) ! 1 or 2 dm = (1.+2.*d(ilst))/(1.+2.*d(ilst)*coszen(i)) albbcksol(i) = sfalb_lnd_bck(i)*dm else @@ -1484,7 +1463,7 @@ end subroutine lsm_ruc_run !! This subroutine contains RUC LSM initialization. subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in + stype, vtype, & ! in tskin_lnd, tskin_wat, tg3, & ! !in zs, dzs, smc, slc, stc, & ! in sh2o, smfrkeep, tslb, smois, & ! out @@ -1507,8 +1486,7 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: stc ! Noah real (kind=kind_phys), dimension(im,lsoil), intent(in ) :: slc ! Noah - integer, dimension(im), intent(inout) :: soiltyp - integer, dimension(im), intent(inout) :: vegtype + integer, dimension(im), intent(in) :: stype, vtype real (kind=kind_phys), dimension(im), intent(inout) :: wetness real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: smois! ruc real (kind=kind_phys), dimension(im,lsoil_ruc), intent(inout) :: tslb ! ruc @@ -1639,13 +1617,13 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in endif if(debug_print) then - write (0,*)'smc(ipr,:) ==', ipr, smc(ipr,:) - write (0,*)'stc(ipr,:) ==', ipr, stc(ipr,:) - write (0,*)'tskin_lnd(:)=',tskin_lnd(:) - write (0,*)'tskin_wat(:)=',tskin_wat(:) - write (0,*)'vegtype(ipr) ==', ipr, vegtype(ipr) - write (0,*)'soiltyp(ipr) ==', ipr, soiltyp(ipr) - write (0,*)'its,ite,jts,jte ',its,ite,jts,jte + write (0,*)'smc(ipr,:) =', ipr, smc(ipr,:) + write (0,*)'stc(ipr,:) =', ipr, stc(ipr,:) + write (0,*)'tskin_lnd(ipr) =', tskin_lnd(ipr) + write (0,*)'tskin_wat(ipr) =', tskin_wat(ipr) + write (0,*)'vtype(ipr) =', ipr, vtype(ipr) + write (0,*)'stype(ipr) =', ipr, stype(ipr) + write (0,*)'its,ite,jts,jte =',its,ite,jts,jte endif @@ -1654,8 +1632,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in sst(i,j) = tskin_wat(i) tbot(i,j) = tg3(i) - ivgtyp(i,j) = vegtype(i) - isltyp(i,j) = soiltyp(i) + ivgtyp(i,j) = vtype(i) + isltyp(i,j) = stype(i) if (slmsk(i) == 0.) then !-- water tsk(i,j) = tskin_wat(i) @@ -1679,8 +1657,8 @@ subroutine rucinit (restart, im, lsoil_ruc, lsoil, nlev, & ! in !--- initialize smcwlt2 and smcref2 with Noah values if(slmsk(i) == 1.) then - smcref2 (i) = REFSMCnoah(soiltyp(i)) - smcwlt2 (i) = WLTSMCnoah(soiltyp(i)) + smcref2 (i) = REFSMCnoah(stype(i)) + smcwlt2 (i) = WLTSMCnoah(stype(i)) else smcref2 (i) = 1. smcwlt2 (i) = 0. diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index bdb058343..c793b5b9a 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -147,21 +147,19 @@ intent = in optional = F [stype] - standard_name = soil_type_classification_real + standard_name = soil_type_classification long_name = soil type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_dimension) - type = real - kind = kind_phys + type = integer intent = in optional = F [q1] @@ -758,21 +756,21 @@ kind = kind_phys intent = in optional = F -[soiltyp] +[stype] standard_name = soil_type_classification long_name = soil type at each grid cell units = index dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = in optional = F -[vegtype] +[vtype] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell units = index dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = in optional = F [sigmaf] standard_name = vegetation_area_fraction diff --git a/physics/sfc_noah_wrfv4_interstitial.F90 b/physics/sfc_noah_wrfv4_interstitial.F90 index 7b37de568..ee66b0092 100644 --- a/physics/sfc_noah_wrfv4_interstitial.F90 +++ b/physics/sfc_noah_wrfv4_interstitial.F90 @@ -150,7 +150,8 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & logical, dimension(:), intent(in) :: flag_guess, flag_iter, land real(kind=kind_phys), dimension(:), intent(in) :: sfcprs, tprcp, sfctmp, q1, prslki, wind, cm, ch, snwdph - real(kind=kind_phys), dimension(:), intent(in) :: weasd, tsfc, vtype + real(kind=kind_phys), dimension(:), intent(in) :: weasd, tsfc + integer , dimension(:), intent(in) :: vtype real(kind=kind_phys), dimension(:,:), intent(in) :: smc, stc, slc logical, dimension(:), intent(inout) :: flag_lsm, flag_lsm_glacier @@ -179,7 +180,7 @@ subroutine sfc_noah_wrfv4_pre_run (im, nsoil, ialb, isice, land, & !from module_sf_noahdrv.F/lsminit if (.not. restart .and. first_time_step .and. ialb == 0) then do i = 1, im - snoalb(i) = maxalb(int(0.5 + vtype(i)))*0.01 + snoalb(i) = maxalb(vtype(i))*0.01 end do end if diff --git a/physics/sfc_noah_wrfv4_interstitial.meta b/physics/sfc_noah_wrfv4_interstitial.meta index bff028fdc..e2d98e15a 100644 --- a/physics/sfc_noah_wrfv4_interstitial.meta +++ b/physics/sfc_noah_wrfv4_interstitial.meta @@ -349,12 +349,11 @@ intent = in optional = F [vtype] - standard_name = vegetation_type_classification_real + standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys + type = integer intent = in optional = F [smc] From a442f8043035c73dd8b6ce178db5632482adf458 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 15 Sep 2021 12:20:29 -0600 Subject: [PATCH 2/9] Update physics/GFS_debug.F90 to reflect the recent changes to the GFS DDTs --- physics/GFS_debug.F90 | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2de372e59..54830660a 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -544,18 +544,18 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%emis_lnd', Sfcprop%emis_lnd) ! NoahMP and RUC if (Model%lsm == Model%lsm_ruc .or. Model%lsm == Model%lsm_noahmp) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdvis_lnd', Sfcprop%albdvis_lnd) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdnir_lnd', Sfcprop%albdnir_lnd) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albivis_lnd', Sfcprop%albivis_lnd) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albinir_lnd', Sfcprop%albinir_lnd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdirvis_lnd', Sfcprop%albdirvis_lnd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdirnir_lnd', Sfcprop%albdirnir_lnd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdifvis_lnd', Sfcprop%albdifvis_lnd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdifnir_lnd', Sfcprop%albdifnir_lnd) end if ! RUC only if (Model%lsm == Model%lsm_ruc) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%emis_ice', Sfcprop%emis_ice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdvis_ice', Sfcprop%albdvis_ice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdnir_ice', Sfcprop%albdnir_ice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albivis_ice', Sfcprop%albivis_ice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albinir_ice', Sfcprop%albinir_ice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdirvis_ice', Sfcprop%albdirvis_ice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdifvis_ice', Sfcprop%albdifvis_ice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdirnir_ice', Sfcprop%albdirnir_ice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%albdifnir_ice', Sfcprop%albdifnir_ice) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sfalb_lnd', Sfcprop%sfalb_lnd) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sfalb_ice', Sfcprop%sfalb_ice) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sfalb_lnd_bck', Sfcprop%sfalb_lnd_bck) @@ -1199,6 +1199,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_water ', Interstitial%evap_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ext_diag_thompson_reset', Interstitial%ext_diag_thompson_reset) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffhh_ice ', Interstitial%ffhh_ice ) @@ -1262,6 +1263,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kpbl ', Interstitial%kpbl ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kt ', Interstitial%kt ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ktop ', Interstitial%ktop ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%max_hourly_reset ', Interstitial%max_hourly_reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mbota ', Interstitial%mbota ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mtopa ', Interstitial%mtopa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nday ', Interstitial%nday ) @@ -1286,7 +1288,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_ice ', Interstitial%rb_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_land ', Interstitial%rb_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_water ', Interstitial%rb_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%reset ', Interstitial%reset ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rhc ', Interstitial%rhc ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%runoff ', Interstitial%runoff ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_q ', Interstitial%save_q ) @@ -1320,7 +1321,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_land ', Interstitial%stress_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_water ', Interstitial%stress_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%theta ', Interstitial%theta ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tice ', Interstitial%tice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tlvl ', Interstitial%tlvl ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tlyr ', Interstitial%tlyr ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) @@ -1330,7 +1330,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_ice ', Interstitial%tsfc_ice ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_land ', Interstitial%tsfc_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_water ', Interstitial%tsfc_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfg ', Interstitial%tsfg ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ice ', Interstitial%tsurf_ice ) From b063048438c4b7a14d5bb8efdfdd93ca4434475d Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 16 Sep 2021 09:16:37 -0600 Subject: [PATCH 3/9] Add code to reverse changes to vegetation/soil/slope type to GFS_surface_generic_post so that all output files are 100% identical --- physics/GFS_surface_generic.F90 | 38 ++++++++++++++++++++++++- physics/GFS_surface_generic.meta | 48 ++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 1 deletion(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 0826f32b6..1b72ba203 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -262,7 +262,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_cpl, & v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & - runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, errmsg, errflg) + runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, & + isot, ivegsrc, islmsk, vtype, stype, slope, errmsg, errflg) implicit none @@ -292,6 +293,11 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, real(kind=kind_phys), dimension(:), intent(out) :: hflxq real(kind=kind_phys), dimension(:), intent(out) :: hffac + ! DH* - DO WE NEED THIS? SEE BELOW? + integer, intent(in) :: isot, ivegsrc, islmsk(:) + integer, intent(inout) :: vtype(:), stype(:), slope(:) + ! *DH + ! CCPP error handling variables character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -430,6 +436,36 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif + ! DH* cludge - DO WE NEED THIS + do i=1,im + if (islmsk(i) == 2) then + if (isot == 1 .and. stype(i) == 16) then + stype(i) = 0 + elseif (stype(i) == 9) then + stype(i) = 0 + endif + if ( (ivegsrc == 0 .or. ivegsrc == 4) .and. vtype(i) == 24) then + vtype(i) = 0 + elseif (ivegsrc == 1 .and. vtype(i) == 15) then + vtype(i) = 0 + elseif (ivegsrc == 2 .and. vtype(i) == 13) then + vtype(i) = 0 + elseif ( (ivegsrc == 3 .or. ivegsrc == 5) .and. vtype(i) == 15) then + vtype(i) = 0 + endif + if (slope(i) == 9) slope(i) = 0 + else + ! DH* REMOVE else block if not needeed - create separate subroutine to be called by both init and run? + !soiltyp(i) = int( stype(i)+0.5_kind_phys ) + !vegtype(i) = int( vtype(i)+0.5_kind_phys ) + !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp + !if (vegtype(i) < 1) vegtype(i) = 17 + !if (slopetyp(i) < 1) slopetyp(i) = 1 + ! *DH + endif + enddo + ! *DH cludge + end subroutine GFS_surface_generic_post_run end module GFS_surface_generic_post diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index c7b24446a..853856587 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -1352,6 +1352,54 @@ kind = kind_phys intent = out optional = F +[isot] + standard_name = control_for_soil_type_dataset + long_name = soil type dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[ivegsrc] + standard_name = control_for_vegetation_dataset + long_name = land use dataset choice + units = index + dimensions = () + type = integer + intent = in + optional = F +[islmsk] + standard_name = sea_land_ice_mask + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From ac03a54abe5266e28077c7c748813ef79bb12a8a Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Thu, 16 Sep 2021 12:06:22 -0600 Subject: [PATCH 4/9] Add logic to save and restore vegetation/soil/slope types before/after surface physics --- physics/GFS_debug.F90 | 5 +++ physics/GFS_surface_generic.F90 | 49 ++++++++++------------------- physics/GFS_surface_generic.meta | 54 ++++++++++++++++++++++++++++++-- 3 files changed, 73 insertions(+), 35 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 54830660a..6befa53d2 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1463,6 +1463,11 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cloud_overlap_param ', Interstitial%cloud_overlap_param ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_overlap_param', Interstitial%precip_overlap_param ) end if + ! DH* + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vtype_save', Interstitial%vtype_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stype_save', Interstitial%stype_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slope_save', Interstitial%slope_save) + ! *DH end if #ifdef OPENMP !$OMP BARRIER diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 1b72ba203..a00850224 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -81,7 +81,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, sfc_wts_inv, & cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) + wind, u1, v1, cnvwind, smcwlt2, smcref2, & + vtype_save, stype_save, slope_save, & + errmsg, errflg) use surface_perturbation, only: cdfnor @@ -94,6 +96,8 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 integer, dimension(:), intent(inout) :: vtype, stype, slope + ! DH* - DO WE NEED THIS? SEE BELOW + integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) real(kind=kind_phys), dimension(:), intent(inout) :: tsfc real(kind=kind_phys), dimension(:,:), intent(in) :: phil @@ -175,6 +179,11 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! End of stochastic physics / surface perturbation + ! DH* DO WE NEED THIS??? + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) + do i=1,im sigmaf(i) = max(vfrac(i), 0.01_kind_phys) islmsk_cice(i) = islmsk(i) @@ -263,7 +272,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, v10mi_cpl, tsfci_cpl, psurfi_cpl, nnirbmi_cpl, nnirdfi_cpl, nvisbmi_cpl, nvisdfi_cpl, nswsfci_cpl, nswsfc_cpl, nnirbm_cpl, & nnirdf_cpl, nvisbm_cpl, nvisdf_cpl, gflux, evbsa, evcwa, transa, sbsnoa, snowca, snohfa, ep, & runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, & - isot, ivegsrc, islmsk, vtype, stype, slope, errmsg, errflg) + isot, ivegsrc, islmsk, vtype, stype, slope, vtype_save, stype_save, slope_save, errmsg, errflg) implicit none @@ -293,8 +302,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, real(kind=kind_phys), dimension(:), intent(out) :: hflxq real(kind=kind_phys), dimension(:), intent(out) :: hffac - ! DH* - DO WE NEED THIS? SEE BELOW? - integer, intent(in) :: isot, ivegsrc, islmsk(:) + ! DH* - DO WE NEED THIS? SEE BELOW + integer, intent(in) :: isot, ivegsrc, islmsk(:), vtype_save(:), stype_save(:), slope_save(:) integer, intent(inout) :: vtype(:), stype(:), slope(:) ! *DH @@ -436,34 +445,10 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif - ! DH* cludge - DO WE NEED THIS - do i=1,im - if (islmsk(i) == 2) then - if (isot == 1 .and. stype(i) == 16) then - stype(i) = 0 - elseif (stype(i) == 9) then - stype(i) = 0 - endif - if ( (ivegsrc == 0 .or. ivegsrc == 4) .and. vtype(i) == 24) then - vtype(i) = 0 - elseif (ivegsrc == 1 .and. vtype(i) == 15) then - vtype(i) = 0 - elseif (ivegsrc == 2 .and. vtype(i) == 13) then - vtype(i) = 0 - elseif ( (ivegsrc == 3 .or. ivegsrc == 5) .and. vtype(i) == 15) then - vtype(i) = 0 - endif - if (slope(i) == 9) slope(i) = 0 - else - ! DH* REMOVE else block if not needeed - create separate subroutine to be called by both init and run? - !soiltyp(i) = int( stype(i)+0.5_kind_phys ) - !vegtype(i) = int( vtype(i)+0.5_kind_phys ) - !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp - !if (vegtype(i) < 1) vegtype(i) = 17 - !if (slopetyp(i) < 1) slopetyp(i) = 1 - ! *DH - endif - enddo + ! DH* cludge - DO WE NEED THIS ??? + vtype(:) = vtype_save(:) + stype(:) = stype_save(:) + slope(:) = slope_save(:) ! *DH cludge end subroutine GFS_surface_generic_post_run diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 853856587..e36e78a92 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -159,6 +159,30 @@ type = integer intent = inout optional = F +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = out + optional = F [prsik_1] standard_name = surface_dimensionless_exner_function long_name = dimensionless Exner function at lowest model interface @@ -1380,7 +1404,7 @@ standard_name = vegetation_type_classification long_name = vegetation type for lsm units = index - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = integer intent = inout optional = F @@ -1388,7 +1412,7 @@ standard_name = soil_type_classification long_name = soil type for lsm units = index - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = integer intent = inout optional = F @@ -1396,10 +1420,34 @@ standard_name = surface_slope_classification long_name = sfc slope type for lsm units = index - dimensions = (horizontal_dimension) + dimensions = (horizontal_loop_extent) type = integer intent = inout optional = F +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_loop_extent) + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From d45dc43d766bdddd4bbab94de1cfd1acdbf8c9bc Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 20 Sep 2021 08:23:03 -0600 Subject: [PATCH 5/9] Further optimization and code changes for b4b results --- physics/GFS_surface_generic.F90 | 110 +++++++++++++++---------------- physics/GFS_surface_generic.meta | 16 +++++ 2 files changed, 70 insertions(+), 56 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index a00850224..9fa81c127 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -19,12 +19,12 @@ module GFS_surface_generic_pre !> \section arg_table_GFS_surface_generic_pre_init Argument Table !! \htmlinclude GFS_surface_generic_pre_init.html !! - subroutine GFS_surface_generic_pre_init (im, slmsk, isot, ivegsrc, stype, vtype, slope, errmsg, errflg) + subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, errmsg, errflg) implicit none ! Interface variables - integer, intent(in) :: im, isot, ivegsrc + integer, intent(in) :: nthreads, im, isot, ivegsrc real(kind_phys), dimension(:), intent(in) :: slmsk integer, dimension(:), intent(inout) :: vtype, stype, slope @@ -33,39 +33,15 @@ subroutine GFS_surface_generic_pre_init (im, slmsk, isot, ivegsrc, stype, vtype, integer, intent(out) :: errflg ! Local variables - integer :: i + integer, dimension(1:im) :: islmsk + integer :: i ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - do i=1,im - if (nint(slmsk(i)) == 2) then - if (isot == 1) then - stype(i) = 16 - else - stype(i) = 9 - endif - if (ivegsrc == 0 .or. ivegsrc == 4) then - vtype(i) = 24 - elseif (ivegsrc == 1) then - vtype(i) = 15 - elseif (ivegsrc == 2) then - vtype(i) = 13 - elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vtype(i) = 15 - endif - slope(i) = 9 - else - ! DH* remove else block if not needed - !soiltyp(i) = int( stype(i)+0.5_kind_phys ) - !vegtype(i) = int( vtype(i)+0.5_kind_phys ) - !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp - !if (vegtype(i) < 1) vegtype(i) = 17 - !if (slopetyp(i) < 1) slopetyp(i) = 1 - ! *DH - endif - enddo + islmsk = nint(slmsk) + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) end subroutine GFS_surface_generic_pre_init @@ -75,7 +51,7 @@ end subroutine GFS_surface_generic_pre_finalize !> \section arg_table_GFS_surface_generic_pre_run Argument Table !! \htmlinclude GFS_surface_generic_pre_run.html !! - subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & + subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & prsik_1, prslk_1, tsfc, phil, con_g, sigmaf, work3, zlvl, & drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & lndp_var_list, lndp_prt_list, & @@ -90,7 +66,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, implicit none ! Interface variables - integer, intent(in) :: im, levs, isot, ivegsrc + integer, intent(in) :: nthreads, im, levs, isot, ivegsrc integer, dimension(:), intent(in) :: islmsk real(kind=kind_phys), intent(in) :: con_g @@ -179,14 +155,54 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! End of stochastic physics / surface perturbation +#if 1 ! DH* DO WE NEED THIS??? vtype_save(:) = vtype(:) stype_save(:) = stype(:) slope_save(:) = slope(:) +#endif + + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) do i=1,im sigmaf(i) = max(vfrac(i), 0.01_kind_phys) islmsk_cice(i) = islmsk(i) + + work3(i) = prsik_1(i) / prslk_1(i) + + zlvl(i) = phil(i,1) * onebg + smcwlt2(i) = zero + smcref2(i) = zero + + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + cnvwind(i) = zero + + enddo + + if (cplflx) then + do i=1,im + islmsk_cice(i) = nint(slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + enddo + endif + + end subroutine GFS_surface_generic_pre_run + + subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + + implicit none + + integer, intent(in) :: nthreads, im, isot, ivegsrc, islmsk(:) + integer, intent(inout) :: vtype(:), stype(:), slope(:) + integer :: i + +!$OMP parallel do num_threads(nthreads) default(none) private(i) & +!$OMP shared(im, isot, ivegsrc, islmsk, vtype, stype, slope) + do i=1,im if (islmsk(i) == 2) then if (isot == 1) then stype(i) = 16 @@ -208,34 +224,14 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, !soiltyp(i) = int( stype(i)+0.5_kind_phys ) !vegtype(i) = int( vtype(i)+0.5_kind_phys ) !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp - !if (vegtype(i) < 1) vegtype(i) = 17 - !if (slopetyp(i) < 1) slopetyp(i) = 1 + if (vtype(i) < 1) vtype(i) = 17 + if (slope(i) < 1) slope(i) = 1 ! *DH endif - - work3(i) = prsik_1(i) / prslk_1(i) - - zlvl(i) = phil(i,1) * onebg - smcwlt2(i) = zero - smcref2(i) = zero - - wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) - cnvwind(i) = zero - enddo +!$OMP end parallel do - if (cplflx) then - do i=1,im - islmsk_cice(i) = nint(slimskin_cpl(i)) - flag_cice(i) = (islmsk_cice(i) == 4) - enddo - endif - - end subroutine GFS_surface_generic_pre_run + end subroutine update_vegetation_soil_slope_type end module GFS_surface_generic_pre @@ -445,11 +441,13 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif +#if 1 ! DH* cludge - DO WE NEED THIS ??? vtype(:) = vtype_save(:) stype(:) = stype_save(:) slope(:) = slope_save(:) ! *DH cludge +#endif end subroutine GFS_surface_generic_post_run diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index e36e78a92..63835f957 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -7,6 +7,14 @@ [ccpp-arg-table] name = GFS_surface_generic_pre_init type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [im] standard_name = horizontal_dimension long_name = horizontal dimension @@ -86,6 +94,14 @@ [ccpp-arg-table] name = GFS_surface_generic_pre_run type = scheme +[nthreads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [im] standard_name = horizontal_loop_extent long_name = horizontal loop extent From a80ad971c6b25959e1e272666f7c752d81436ff1 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Mon, 20 Sep 2021 14:57:27 -0600 Subject: [PATCH 6/9] Code cleanup and consistent saving and restoring of vegetation/soil/slope types --- physics/GFS_debug.F90 | 104 +++++++++++++++---------------- physics/GFS_surface_generic.F90 | 85 ++++++++++++++----------- physics/GFS_surface_generic.meta | 100 ++++++++++++++++++++++++++++- physics/sfc_drv_ruc.F90 | 2 +- 4 files changed, 199 insertions(+), 92 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 6befa53d2..dbfa22ab3 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -455,55 +455,58 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, do impi=0,mpisize-1 do iomp=0,ompsize-1 if (mpirank==impi .and. omprank==iomp) then - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Model%kdt' , Model%kdt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Model%kdt' , Model%kdt) ! Sfcprop - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slmsk' , Sfcprop%slmsk) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oceanfrac', Sfcprop%oceanfrac) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%landfrac' , Sfcprop%landfrac) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%lakefrac' , Sfcprop%lakefrac) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfc' , Sfcprop%tsfc) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfco' , Sfcprop%tsfco) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfcl' , Sfcprop%tsfcl) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tisfc' , Sfcprop%tisfc) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snowd' , Sfcprop%snowd) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorl' , Sfcprop%zorl) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorlw' , Sfcprop%zorlw) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorll' , Sfcprop%zorll) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorli' , Sfcprop%zorli) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorlwav' , Sfcprop%zorlwav) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%fice' , Sfcprop%fice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hprime' , Sfcprop%hprime) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sncovr' , Sfcprop%sncovr) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snoalb' , Sfcprop%snoalb) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvsf' , Sfcprop%alvsf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnsf' , Sfcprop%alnsf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvwf' , Sfcprop%alvwf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnwf' , Sfcprop%alnwf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facsf' , Sfcprop%facsf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facwf' , Sfcprop%facwf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slope' , Sfcprop%slope) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmin' , Sfcprop%shdmin) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmax' , Sfcprop%shdmax) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tg3' , Sfcprop%tg3) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vfrac' , Sfcprop%vfrac) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vtype' , Sfcprop%vtype) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype' , Sfcprop%stype) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%uustar' , Sfcprop%uustar) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro' , Sfcprop%oro) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hice' , Sfcprop%hice) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasd' , Sfcprop%weasd) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%canopy' , Sfcprop%canopy) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffmm' , Sfcprop%ffmm) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffhh' , Sfcprop%ffhh) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%f10m' , Sfcprop%f10m) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tprcp' , Sfcprop%tprcp) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%srflag' , Sfcprop%srflag) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slc' , Sfcprop%slc) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%smc' , Sfcprop%smc) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stc' , Sfcprop%stc) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%t2m' , Sfcprop%t2m) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%q2m' , Sfcprop%q2m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slmsk' , Sfcprop%slmsk) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oceanfrac' , Sfcprop%oceanfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%landfrac' , Sfcprop%landfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%lakefrac' , Sfcprop%lakefrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfc' , Sfcprop%tsfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfco' , Sfcprop%tsfco) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfcl' , Sfcprop%tsfcl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tisfc' , Sfcprop%tisfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snowd' , Sfcprop%snowd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorl' , Sfcprop%zorl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorlw' , Sfcprop%zorlw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorll' , Sfcprop%zorll) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorli' , Sfcprop%zorli) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorlwav' , Sfcprop%zorlwav) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%fice' , Sfcprop%fice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hprime' , Sfcprop%hprime) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sncovr' , Sfcprop%sncovr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snoalb' , Sfcprop%snoalb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvsf' , Sfcprop%alvsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnsf' , Sfcprop%alnsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvwf' , Sfcprop%alvwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnwf' , Sfcprop%alnwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facsf' , Sfcprop%facsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facwf' , Sfcprop%facwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slope' , Sfcprop%slope) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slope_save', Sfcprop%slope_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmin' , Sfcprop%shdmin) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmax' , Sfcprop%shdmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tg3' , Sfcprop%tg3) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vfrac' , Sfcprop%vfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vtype' , Sfcprop%vtype) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vtype_save', Sfcprop%vtype_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype' , Sfcprop%stype) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype_save', Sfcprop%stype_save) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%uustar' , Sfcprop%uustar) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro' , Sfcprop%oro) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hice' , Sfcprop%hice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasd' , Sfcprop%weasd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%canopy' , Sfcprop%canopy) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffmm' , Sfcprop%ffmm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffhh' , Sfcprop%ffhh) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%f10m' , Sfcprop%f10m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tprcp' , Sfcprop%tprcp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%srflag' , Sfcprop%srflag) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slc' , Sfcprop%slc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%smc' , Sfcprop%smc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stc' , Sfcprop%stc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%t2m' , Sfcprop%t2m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%q2m' , Sfcprop%q2m) if (Model%nstf_name(1)>0) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tref ', Sfcprop%tref) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%z_c ', Sfcprop%z_c) @@ -1463,11 +1466,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cloud_overlap_param ', Interstitial%cloud_overlap_param ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_overlap_param', Interstitial%precip_overlap_param ) end if - ! DH* - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vtype_save', Interstitial%vtype_save) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stype_save', Interstitial%stype_save) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slope_save', Interstitial%slope_save) - ! *DH end if #ifdef OPENMP !$OMP BARRIER diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 9fa81c127..dc2b136ad 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -19,29 +19,37 @@ module GFS_surface_generic_pre !> \section arg_table_GFS_surface_generic_pre_init Argument Table !! \htmlinclude GFS_surface_generic_pre_init.html !! - subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, errmsg, errflg) + subroutine GFS_surface_generic_pre_init (nthreads, im, slmsk, isot, ivegsrc, stype, vtype, slope, & + vtype_save, stype_save, slope_save, errmsg, errflg) - implicit none + implicit none + + ! Interface variables + integer, intent(in) :: nthreads, im, isot, ivegsrc + real(kind_phys), dimension(:), intent(in) :: slmsk + integer, dimension(:), intent(inout) :: vtype, stype, slope + integer, dimension(:), intent(out) :: vtype_save, stype_save, slope_save + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg - ! Interface variables - integer, intent(in) :: nthreads, im, isot, ivegsrc - real(kind_phys), dimension(:), intent(in) :: slmsk - integer, dimension(:), intent(inout) :: vtype, stype, slope + ! Local variables + integer, dimension(1:im) :: islmsk + integer :: i - ! CCPP error handling - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 - ! Local variables - integer, dimension(1:im) :: islmsk - integer :: i + islmsk = nint(slmsk) - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 + ! Save current values of vegetation, soil and slope type + vtype_save(:) = vtype(:) + stype_save(:) = stype(:) + slope_save(:) = slope(:) - islmsk = nint(slmsk) - call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) + call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) end subroutine GFS_surface_generic_pre_init @@ -72,8 +80,7 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, real(kind=kind_phys), intent(in) :: con_g real(kind=kind_phys), dimension(:), intent(in) :: vfrac, prsik_1, prslk_1 integer, dimension(:), intent(inout) :: vtype, stype, slope - ! DH* - DO WE NEED THIS? SEE BELOW - integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) + integer, dimension(:), intent(out) :: vtype_save(:), stype_save(:), slope_save(:) real(kind=kind_phys), dimension(:), intent(inout) :: tsfc real(kind=kind_phys), dimension(:,:), intent(in) :: phil @@ -155,12 +162,10 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, ! End of stochastic physics / surface perturbation -#if 1 - ! DH* DO WE NEED THIS??? + ! Save current values of vegetation, soil and slope type vtype_save(:) = vtype(:) stype_save(:) = stype(:) slope_save(:) = slope(:) -#endif call update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk, vtype, stype, slope) @@ -220,13 +225,8 @@ subroutine update_vegetation_soil_slope_type(nthreads, im, isot, ivegsrc, islmsk endif slope(i) = 9 else - ! DH* REMOVE else block if not needeed - create separate subroutine to be called by both init and run? - !soiltyp(i) = int( stype(i)+0.5_kind_phys ) - !vegtype(i) = int( vtype(i)+0.5_kind_phys ) - !slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp if (vtype(i) < 1) vtype(i) = 17 if (slope(i) < 1) slope(i) = 1 - ! *DH endif enddo !$OMP end parallel do @@ -250,7 +250,27 @@ module GFS_surface_generic_post contains - subroutine GFS_surface_generic_post_init () +!> \section arg_table_GFS_surface_generic_post_init Argument Table +!! \htmlinclude GFS_surface_generic_post_init.html +!! + subroutine GFS_surface_generic_post_init (vtype, stype, slope, vtype_save, stype_save, slope_save, errmsg, errflg) + + integer, dimension(:), intent(in) :: vtype_save, stype_save, slope_save + integer, dimension(:), intent(out) :: vtype, stype, slope + + ! CCPP error handling + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Restore vegetation, soil and slope type + vtype(:) = vtype_save(:) + stype(:) = stype_save(:) + slope(:) = slope_save(:) + end subroutine GFS_surface_generic_post_init subroutine GFS_surface_generic_post_finalize() @@ -298,10 +318,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, real(kind=kind_phys), dimension(:), intent(out) :: hflxq real(kind=kind_phys), dimension(:), intent(out) :: hffac - ! DH* - DO WE NEED THIS? SEE BELOW integer, intent(in) :: isot, ivegsrc, islmsk(:), vtype_save(:), stype_save(:), slope_save(:) - integer, intent(inout) :: vtype(:), stype(:), slope(:) - ! *DH + integer, intent(out) :: vtype(:), stype(:), slope(:) ! CCPP error handling variables character(len=*), intent(out) :: errmsg @@ -441,13 +459,10 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, enddo endif -#if 1 - ! DH* cludge - DO WE NEED THIS ??? + ! Restore vegetation, soil and slope type vtype(:) = vtype_save(:) stype(:) = stype_save(:) slope(:) = slope_save(:) - ! *DH cludge -#endif end subroutine GFS_surface_generic_post_run diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 63835f957..f593a1633 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -72,6 +72,30 @@ type = integer intent = inout optional = F +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -524,6 +548,76 @@ type = scheme dependencies = machine.F,surface_perturbation.F90 +######################################################################## +[ccpp-arg-table] + name = GFS_surface_generic_post_init + type = scheme +[vtype] + standard_name = vegetation_type_classification + long_name = vegetation type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[stype] + standard_name = soil_type_classification + long_name = soil type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[slope] + standard_name = surface_slope_classification + long_name = sfc slope type for lsm + units = index + dimensions = (horizontal_dimension) + type = integer + intent = out + optional = F +[vtype_save] + standard_name = vegetation_type_classification_save + long_name = vegetation type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[stype_save] + standard_name = soil_type_classification_save + long_name = soil type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[slope_save] + standard_name = surface_slope_classification_save + long_name = sfc slope type for lsm save + units = index + dimensions = (horizontal_dimension) + type = integer + intent = in + optional = F +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out + optional = F +[errflg] + standard_name = ccpp_error_flag + long_name = error flag for error handling in CCPP + units = flag + dimensions = () + type = integer + intent = out + optional = F + ######################################################################## [ccpp-arg-table] name = GFS_surface_generic_post_run @@ -1422,7 +1516,7 @@ units = index dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = out optional = F [stype] standard_name = soil_type_classification @@ -1430,7 +1524,7 @@ units = index dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = out optional = F [slope] standard_name = surface_slope_classification @@ -1438,7 +1532,7 @@ units = index dimensions = (horizontal_loop_extent) type = integer - intent = inout + intent = out optional = F [vtype_save] standard_name = vegetation_type_classification_save diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index 26e4f2905..41ad55130 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -116,7 +116,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + ! Consistency checks if (lsm/=lsm_ruc) then write(errmsg,'(*(a))') 'Logic error: namelist choice of ', & From d29e48be195cbac10a424a148e6e4c2630f15bcd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 1 Oct 2021 10:21:20 -0600 Subject: [PATCH 7/9] Cleanup work: fix typos, remove old dependencies and comments in source code and metadata files --- physics/GFS_rrtmgp_pre.meta | 2 +- physics/module_SGSCloud_RadPre.F90 | 2 +- physics/rrtmg_lw_pre.F90 | 2 -- physics/rrtmg_sw_pre.F90 | 2 -- physics/rrtmg_sw_pre.meta | 2 +- physics/rrtmgp_lw_pre.F90 | 2 -- physics/rrtmgp_lw_pre.meta | 2 +- 7 files changed, 4 insertions(+), 10 deletions(-) diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index ddda82bb6..e33663748 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -2,7 +2,7 @@ name = GFS_rrtmgp_pre type = scheme dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f - dependencies = radiation_astronomy.f,radiation_clouds.f,module_mp_thompson.F90,radiation_gases.f,radiation_surface.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 + dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_tools.F90,rrtmg_lw_cloud_optics.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index 20136ba00..73b72d10a 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -61,7 +61,7 @@ subroutine sgscloud_radpre_run( & ! should be moved to inside the mynn: use machine , only : kind_phys use module_radiation_clouds, only : gethml - use radcons, only: qmin ! Minimum vlaues for varius calculations + use radcons, only: qmin ! Minimum values for various calculations use funcphys, only: fpvs ! Function ot compute sat. vapor pressure over liq. !------------------------------------------------------------------- implicit none diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index 3ace48c0b..6da0e3100 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -1,6 +1,4 @@ !>\file rrtmg_lw_pre.f90 -!! This file contains a call to module_radiation_surface::setemis() to -!! setup surface emissivity for LW radiation. module rrtmg_lw_pre contains diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 index cc329f180..1c7d3d76b 100644 --- a/physics/rrtmg_sw_pre.F90 +++ b/physics/rrtmg_sw_pre.F90 @@ -1,6 +1,4 @@ !>\file rrtmg_sw_pre.f90 -!! This file contains a subroutine to module_radiation_surface::setalb() to -!! setup surface albedo for SW radiation. module rrtmg_sw_pre contains diff --git a/physics/rrtmg_sw_pre.meta b/physics/rrtmg_sw_pre.meta index 9edf59e73..abf63a447 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rrtmg_sw_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmg_sw_pre type = scheme - dependencies = iounitdef.f,machine.F,radiation_surface.f + dependencies = iounitdef.f,machine.F ######################################################################## [ccpp-arg-table] diff --git a/physics/rrtmgp_lw_pre.F90 b/physics/rrtmgp_lw_pre.F90 index 99318c1b8..d33a4e52c 100644 --- a/physics/rrtmgp_lw_pre.F90 +++ b/physics/rrtmgp_lw_pre.F90 @@ -1,8 +1,6 @@ module rrtmgp_lw_pre use machine, only: & kind_phys ! Working type - use module_radiation_surface, only: & - setemis ! Routine to compute surface-emissivity use mo_gas_optics_rrtmgp, only: & ty_gas_optics_rrtmgp use rrtmgp_lw_gas_optics, only: lw_gas_props diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index 071f1944a..3918f85e4 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrtmgp_lw_pre type = scheme - dependencies = iounitdef.f,machine.F,physparam.f,radiation_surface.f + dependencies = iounitdef.f,machine.F,physparam.f ######################################################################## [ccpp-arg-table] From 9438220dcf0d00fea0ff8ca2a35cd7d96446b1bd Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 1 Oct 2021 12:07:27 -0600 Subject: [PATCH 8/9] Remove stochastic physics arrays that no longer exist from physics/GFS_debug.F90 --- physics/GFS_debug.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index dbfa22ab3..deb88458b 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -694,10 +694,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, else call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wet1 ', Diag%wet1) end if - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebu_wts ', Diag%skebu_wts) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebv_wts ', Diag%skebv_wts) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sppt_wts ', Diag%sppt_wts) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%shum_wts ', Diag%shum_wts) + !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebu_wts ', Diag%skebu_wts) + !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebv_wts ', Diag%skebv_wts) + !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sppt_wts ', Diag%sppt_wts) + !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%shum_wts ', Diag%shum_wts) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%zmtnblck ', Diag%zmtnblck) if (Model%ldiag3d) then !do itracer=2,Model%ntracp100 From 71832dba3bcb241731dccb3115c41f0ec21cd268 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 1 Oct 2021 12:12:13 -0600 Subject: [PATCH 9/9] Fix formatting in physics/GFS_surface_generic.F90 --- physics/GFS_surface_generic.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index 0b3f76920..07d9c1770 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -65,8 +65,7 @@ subroutine GFS_surface_generic_pre_run (nthreads, im, levs, vfrac, islmsk, isot, lndp_var_list, lndp_prt_list, & z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & cplflx, flag_cice, islmsk_cice, slimskin_cpl, & - wind, u1, v1, cnvwind, smcwlt2, smcref2, & - vtype_save, stype_save, slope_save, & + wind, u1, v1, cnvwind, smcwlt2, smcref2, vtype_save, stype_save, slope_save, & errmsg, errflg) use surface_perturbation, only: cdfnor