From d2900143f7de8c3fe79e8135a0bab5f3267267b9 Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Tue, 10 Jan 2023 15:31:25 -0700 Subject: [PATCH 01/64] add sfc_land and allow sbs along with fully coupled --- CODEOWNERS | 2 + physics/noahmpdrv.F90 | 12 ++- physics/noahmpdrv.meta | 14 ++++ physics/sfc_land.f | 146 ++++++++++++++++++++++++++++++++ physics/sfc_land.meta | 186 +++++++++++++++++++++++++++++++++++++++++ 5 files changed, 358 insertions(+), 2 deletions(-) create mode 100644 physics/sfc_land.f create mode 100644 physics/sfc_land.meta diff --git a/CODEOWNERS b/CODEOWNERS index cf7a886aa..19e0eb2a5 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -126,6 +126,8 @@ physics/h2ophys.* @AlexBelochitski-NOAA physics/sfc_sice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA physics/sfc_cice.* @wd20xw @climbfuji @SamuelTrahanNOAA @grantfirl @mzhangw @panll @mkavulich @ChunxiZhang-NOAA +physics/sfc_land.* @uturuncoglu @barlage + ######################################################################## # Lines starting with '#' are comments. diff --git a/physics/noahmpdrv.F90 b/physics/noahmpdrv.F90 index fed823ead..d15a9e82a 100644 --- a/physics/noahmpdrv.F90 +++ b/physics/noahmpdrv.F90 @@ -140,7 +140,7 @@ subroutine noahmpdrv_run & iopt_stc, iopt_trs,xlatin, xcoszin, iyrlen, julian, garea, & rainn_mp, rainc_mp, snow_mp, graupel_mp, ice_mp, & con_hvap, con_cp, con_jcal, rhoh2o, con_eps, con_epsm1, & - con_fvirt, con_rd, con_hfus, thsfc_loc, & + con_fvirt, con_rd, con_hfus, thsfc_loc, cpllnd, cpllnd2atm,& ! --- in/outs: weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & @@ -274,6 +274,9 @@ subroutine noahmpdrv_run & logical , intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation + logical , intent(in) :: cpllnd ! Flag for land coupling (atm->lnd) + logical , intent(in) :: cpllnd2atm ! Flag for land coupling (lnd->atm) + real(kind=kind_phys), dimension(:) , intent(inout) :: weasd ! water equivalent accumulated snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: snwdph ! snow depth [mm] real(kind=kind_phys), dimension(:) , intent(inout) :: tskin ! ground surface skin temperature [K] @@ -601,7 +604,12 @@ subroutine noahmpdrv_run & errmsg = '' errflg = 0 -do i = 1, im +! +! --- Just return if external land component is activated for two-way interaction +! + if (cpllnd .and. cpllnd2atm) return + + do i = 1, im if (flag_iter(i) .and. dry(i)) then diff --git a/physics/noahmpdrv.meta b/physics/noahmpdrv.meta index 3235b7c90..643987d98 100644 --- a/physics/noahmpdrv.meta +++ b/physics/noahmpdrv.meta @@ -611,6 +611,20 @@ dimensions = () type = logical intent = in +[cpllnd] + standard_name = flag_for_land_coupling + long_name = flag controlling cpllnd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cpllnd2atm] + standard_name = flag_for_one_way_land_coupling_to_atmosphere + long_name = flag controlling land coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in [weasd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land diff --git a/physics/sfc_land.f b/physics/sfc_land.f new file mode 100644 index 000000000..0c3130bbe --- /dev/null +++ b/physics/sfc_land.f @@ -0,0 +1,146 @@ +!> \file sfc_land.f +!! This file contains the code for coupling to land component + +!> This module contains the CCPP-compliant GFS land post +!! interstitial codes, which returns updated surface +!! properties such as latent heat and sensible heat +!! provided by the component version of land model + +!> This module contains the CCPP-compliant GFS land scheme. + module sfc_land + + contains + +!> \defgroup sfc_land for coupling to land +!! @{ +!! \section diagram Calling Hierarchy Diagram +!! \section intraphysics Intraphysics Communication +!! +!> \brief Brief description of the subroutine +!! +!! \section arg_table_sfc_land_run Arguments +!! \htmlinclude sfc_land_run.html +!! + +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + + +!! use physcons, only : hvap => con_hvap, cp => con_cp, & +!! & rvrdm1 => con_fvirt, rd => con_rd +! +!----------------------------------- + subroutine sfc_land_run & +! --- inputs: + & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & + & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & + & ep_lnd, t2mmp_lnd, q2mp_lnd, & +! --- outputs: + & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & + & errmsg, errflg, naux2d, aux2d + & ) + +! ===================================================================== ! +! description: ! +! Dec 2022 -- Ufuk Turuncoglu created for coupling to land ! +! ! +! usage: ! +! ! +! call sfc_land ! +! inputs: ! +! ( im, cpllnd, cpllnd2atm, flag_iter, dry, ! +! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! +! ep_lnd, t2mmp_lnd, q2mp_lnd, ! +! outputs: ! +! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! +! errmsg, errflg) ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: +! im - integer, horiz dimension +! cpllnd - logical, flag for land coupling +! cpllnd2atm - logical, flag for land coupling (lnd->atm) +! flag_iter - logical, flag for iteration +! dry - logical, eq T if a point with any land +! sncovr1_lnd - real , surface snow area fraction +! qsurf_lnd - real , specific humidity at sfc +! evap_lnd - real , evaporation from latent heat +! hflx_lnd - real , sensible heat +! ep_lnd - real , surface upward potential latent heat flux +! t2mmp_lnd - real , 2m temperature +! q2mp_lnd - real , 2m specific humidity +! outputs: +! sncovr1 - real , snow cover over land +! qsurf - real , specific humidity at sfc +! evap - real , evaporation from latent heat +! hflx - real , sensible heat +! ep - real , potential evaporation +! t2mmp - real , temperature at 2m +! q2mp - real , specific humidity at 2m +! ==================== end of description ===================== ! +! +! + use machine , only : kind_phys + implicit none + +! --- inputs: + integer, intent(in) :: im + logical, intent(in) :: cpllnd, cpllnd2atm + logical, dimension(:), intent(in) :: flag_iter + logical, dimension(:), intent(in) :: dry + + real (kind=kind_phys), dimension(:), intent(in) :: & + & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & + & t2mmp_lnd, q2mp_lnd + +! --- outputs: + real (kind=kind_phys), dimension(:), intent(out) :: & + & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer, intent(in) :: naux2d + real(kind_phys), intent(out) :: aux2d(:,:) + +! --- locals: + + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! + if (.not. cpllnd2atm) return +! + do i = 1, im + !if (flag_iter(i) .and. dry(i)) then + !if (dry(i)) then + sncovr1(i) = sncovr1_lnd(i) + qsurf(i) = qsurf_lnd(i) + hflx(i) = hflx_lnd(i) + evap(i) = evap_lnd(i) + ep(i) = ep_lnd(i) + t2mmp(i) = t2mmp_lnd(i) + q2mp(i) = q2mp_lnd(i) + !end if + enddo + + aux2d(:,1) = dry(:) !sncovr1(:) + aux2d(:,2) = qsurf(:) + aux2d(:,3) = hflx(:) + aux2d(:,4) = evap(:) + aux2d(:,5) = ep(:) + aux2d(:,6) = qsurf_lnd(:) !t2mmp(:) + aux2d(:,7) = q2mp(:) + + return +!----------------------------------- + end subroutine sfc_land_run +!----------------------------------- + +!> @} + end module sfc_land diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta new file mode 100644 index 000000000..f31d779ae --- /dev/null +++ b/physics/sfc_land.meta @@ -0,0 +1,186 @@ +[ccpp-table-properties] + name = sfc_land + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = sfc_land_run + type = scheme +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[cpllnd] + standard_name = flag_for_land_coupling + long_name = flag controlling cpllnd collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[cpllnd2atm] + standard_name = flag_for_one_way_land_coupling_to_atmosphere + long_name = flag controlling land coupling to the atmosphere (default off) + units = flag + dimensions = () + type = logical + intent = in +[flag_iter] + standard_name = flag_for_iteration + long_name = flag for iteration + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in +[sncovr1_lnd] + standard_name = surface_snow_area_fraction_over_land_from_land + long_name = surface snow area fraction over land for coupling + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[qsurf_lnd] + standard_name = surface_specific_humidity_over_land_from_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[evap_lnd] + standard_name = surface_upward_latent_heat_flux_over_land_from_land + long_name = sfc latent heat flux input over land for coupling + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[hflx_lnd] + standard_name = surface_upward_sensible_heat_flux_over_land_from_land + long_name = sfc sensible heat flux input over land for coupling + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ep_lnd] + standard_name = surface_upward_potential_latent_heat_flux_over_land_from_land + long_name = surface upward potential latent heat flux over land for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[t2mmp_lnd] + standard_name = temperature_at_2m_over_land_from_land + long_name = 2 meter temperature over land for coupling + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[q2mp_lnd] + standard_name = specific_humidity_at_2m_over_land_from_land + long_name = 2 meter specific humidity over land for coupling + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[sncovr1] + standard_name = surface_snow_area_fraction_over_land + long_name = surface snow area fraction + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[qsurf] + standard_name = surface_specific_humidity_over_land + long_name = surface air saturation specific humidity over land + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[evap] + standard_name = kinematic_surface_upward_latent_heat_flux_over_land + long_name = kinematic surface upward latent heat flux over land + units = kg kg-1 m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[hflx] + standard_name = kinematic_surface_upward_sensible_heat_flux_over_land + long_name = kinematic surface upward sensible heat flux over land + units = K m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_land + long_name = surface upward potential latent heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[t2mmp] + standard_name = temperature_at_2m_from_noahmp + long_name = 2 meter temperature from noahmp + units = K + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[q2mp] + standard_name = specific_humidity_at_2m_from_noahmp + long_name = 2 meter specific humidity from noahmp + units = kg kg-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out +[naux2d] + standard_name = number_of_xy_dimensioned_auxiliary_arrays + long_name = number of 2d auxiliary arrays to output (for debugging) + units = count + dimensions = () + type = integer + intent = in +[aux2d] + standard_name = auxiliary_2d_arrays + long_name = auxiliary 2d arrays to output (for debugging) + units = none + dimensions = (horizontal_loop_extent,number_of_xy_dimensioned_auxiliary_arrays) + type = real + kind = kind_phys + intent = out From c18c6d49c635198cf4bd1b3cddf9c8d4848090d6 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 30 Jan 2023 13:18:03 -0700 Subject: [PATCH 02/64] CCPP scheme simulator. --- physics/ccpp_scheme_simultator.F90 | 593 ++++++++++++++++++++++++++++ physics/ccpp_scheme_simultator.meta | 266 +++++++++++++ 2 files changed, 859 insertions(+) create mode 100644 physics/ccpp_scheme_simultator.F90 create mode 100644 physics/ccpp_scheme_simultator.meta diff --git a/physics/ccpp_scheme_simultator.F90 b/physics/ccpp_scheme_simultator.F90 new file mode 100644 index 000000000..4d53c8860 --- /dev/null +++ b/physics/ccpp_scheme_simultator.F90 @@ -0,0 +1,593 @@ +! ######################################################################################## +! +! CCPP scheme to replace physics schemes with simulated data tendencies. +! +! ######################################################################################## +module ccpp_scheme_simultator + use machine, only: kind_phys + use netcdf + implicit none + + ! + ! Data driven phsyics tendencies + ! + real(kind_phys), allocatable, dimension(:) :: time_data + real(kind_phys), allocatable, dimension(:,:) :: dTdt_LWRAD_data, dTdt_SWRAD_data, & + dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, dudt_GWD_data, & + dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, dTdt_DCNV_data, & + dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data + real(kind_phys), allocatable, dimension(:,:,:) :: dqdt_PBL_data, dqdt_SCNV_data, & + dqdt_DCNV_data, dqdt_cldMP_data + + ! + ! Logical switches for CCPP scheme simulator(s) + ! + logical :: use_RAD_scheme_sim = .false., & + use_PBL_scheme_sim = .false., & + use_GWD_scheme_sim = .false., & + use_SCNV_scheme_sim = .false., & + use_DCNV_scheme_sim = .false., & + use_cldMP_scheme_sim = .false. + logical :: have_dTdt_LWRAD_data = .false., & + have_dTdt_SWRAD_data = .false., & + have_dTdt_PBL_data = .false., & + have_dqdt_PBL_data = .false., & + have_dudt_PBL_data = .false., & + have_dvdt_PBL_data = .false., & + have_dTdt_GWD_data = .false., & + have_dudt_GWD_data = .false., & + have_dvdt_GWD_data = .false., & + have_dTdt_SCNV_data = .false., & + have_dudt_SCNV_data = .false., & + have_dvdt_SCNV_data = .false., & + have_dqdt_SCNV_data = .false., & + have_dTdt_DCNV_data = .false., & + have_dudt_DCNV_data = .false., & + have_dvdt_DCNV_data = .false., & + have_dqdt_DCNV_data = .false., & + have_dTdt_cldMP_data = .false., & + have_dqdt_cldMP_data = .false. + logical :: do_ccpp_scheme_simulator = .false. + + ! Host-model initial time information + integer :: init_year, init_month, init_day, init_hour, init_min, init_sec + + public ccpp_scheme_simultator_init, ccpp_scheme_simultator_run +contains + + ! ###################################################################################### + ! + ! SUBROUTINE ccpp_scheme_simultator_init + ! + ! ###################################################################################### +!! \section arg_table_ccpp_scheme_simultator_init +!! \htmlinclude ccpp_scheme_simultator_init.html +!! + subroutine ccpp_scheme_simultator_init(me, master, nlunit, nml_file, idat, errmsg, errflg) + + ! Inputs + integer, intent (in) :: me, master, nlunit + character(len=*), intent (in) :: nml_file + integer, intent (in), dimension(8) :: idat + + ! Outputs + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: ncid, dimID, varID, status, nlon, nlat, nlev, ntime, ios + character(len=256) :: fileIN + logical :: exists + integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality + + ! Namelist + namelist / scm_data_nml / & + fileIN, use_RAD_scheme_sim, use_PBL_scheme_sim, use_GWD_scheme_sim, use_SCNV_scheme_sim, & + use_DCNV_scheme_sim, use_cldMP_scheme_sim + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Store model initialization time. + init_year = idat(1) + init_month = idat(2) + init_day = idat(3) + init_hour = idat(5) + init_min = idat(6) + init_sec = idat(7) + + ! Read in namelist + inquire (file = trim (nml_file), exist = exists) + if (.not. exists) then + errmsg = 'SCM data tendency :: namelist file: '//trim(nml_file)//' does not exist' + errflg = 1 + return + else + open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = scm_data_nml) + close (nlunit) + + ! Only proceed if scheme simulator requested. + if (use_RAD_scheme_sim .or. use_PBL_scheme_sim .or. use_GWD_scheme_sim .or. & + use_SCNV_scheme_sim .or. use_DCNV_scheme_sim .or. use_cldMP_scheme_sim) then + do_ccpp_scheme_simulator = .true. + else + return + endif + + ! Check that input data file exists + inquire (file = trim (fileIN), exist = exists) + if (.not. exists) then + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' + errflg = 1 + return + endif + + ! Open file (required) + status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) + errflg = 1 + return + endif + + ! Get dimensions (required) + status = nf90_inq_dimid(ncid, 'time', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = ntime) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain time dimension' + errflg = 1 + return + endif + ! + status = nf90_inq_dimid(ncid, 'lev', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = nlev) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain lev dimension' + errflg = 1 + return + endif + + ! Temporal info (required) + status = nf90_inq_varid(ncid, 'times', varID) + if (status == nf90_noerr) then + allocate(time_data(ntime)) + status = nf90_get_var( ncid, varID, time_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' + errflg = 1 + return + endif + + ! Read in physics data tendencies (optional) + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) then + allocate(dTdt_LWRAD_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) + have_dTdt_LWRAD_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) then + allocate(dTdt_SWRAD_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) + have_dTdt_SWRAD_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) then + allocate(dTdt_PBL_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_PBL_data) + have_dTdt_PBL_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) then + allocate(dqdt_PBL_data(nlev, ntime, nTrc)) + status = nf90_get_var( ncid, varID, dqdt_PBL_data) + have_dqdt_PBL_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) then + allocate(dudt_PBL_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dudt_PBL_data) + have_dudt_PBL_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) then + allocate(dvdt_PBL_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dvdt_PBL_data) + have_dvdt_PBL_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) then + allocate(dTdt_GWD_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_GWD_data) + have_dTdt_GWD_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) then + allocate(dudt_GWD_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dudt_GWD_data) + have_dudt_GWD_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) then + allocate(dvdt_GWD_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dvdt_GWD_data) + have_dvdt_GWD_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) then + allocate(dTdt_SCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_SCNV_data) + have_dTdt_SCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) then + allocate(dudt_SCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dudt_SCNV_data) + have_dudt_SCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) then + allocate(dvdt_SCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dvdt_SCNV_data) + have_dvdt_SCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) then + allocate(dqdt_SCNV_data(nlev, ntime, nTrc)) + status = nf90_get_var( ncid, varID, dqdt_SCNV_data) + have_dqdt_SCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) then + allocate(dTdt_DCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_DCNV_data) + have_dTdt_DCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) then + allocate(dudt_DCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dudt_DCNV_data) + have_dudt_DCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) then + allocate(dvdt_DCNV_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dvdt_DCNV_data) + have_dvdt_DCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) then + allocate(dqdt_DCNV_data(nlev, ntime, nTrc)) + status = nf90_get_var( ncid, varID, dqdt_DCNV_data) + have_dqdt_DCNV_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) then + allocate(dTdt_cldMP_data(nlev, ntime)) + status = nf90_get_var( ncid, varID, dTdt_cldMP_data) + have_dTdt_cldMP_data = .true. + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) then + allocate(dqdt_cldMP_data(nlev, ntime, nTrc)) + status = nf90_get_var( ncid, varID, dqdt_cldMP_data) + have_dqdt_cldMP_data = .true. + endif + + ! + if (me == 0) then + print*, "--- Using SCM data tendencies ---" + print*, "---------------------------------" + print*, " " + print*, "use_RAD_scheme_sim: ", use_RAD_scheme_sim + print*, " dTdt_LWRAD_data: ", have_dTdt_LWRAD_data + print*, " dTdt_SWRAD_data: ", have_dTdt_SWRAD_data + print*, "use_PBL_scheme_sim: ", use_PBL_scheme_sim + print*, " dTdt_PBL_data: ", have_dTdt_PBL_data + print*, " dqdt_PBL_data: ", have_dqdt_PBL_data + print*, " dudt_PBL_data: ", have_dudt_PBL_data + print*, " dvdt_PBL_data: ", have_dvdt_PBL_data + print*, "use_GWD_scheme_sim: ", use_GWD_scheme_sim + print*, " dTdt_gwd_data: ", have_dTdt_GWD_data + print*, " dudt_gwd_data: ", have_dudt_GWD_data + print*, " dvdt_gwd_data: ", have_dvdt_GWD_data + print*, "use_SCNV_scheme_sim: ", use_SCNV_scheme_sim + print*, " dTdt_SCNV_data: ", have_dTdt_SCNV_data + print*, " dudt_SCNV_data: ", have_dudt_SCNV_data + print*, " dvdt_SCNV_data: ", have_dvdt_SCNV_data + print*, " dqdt_SCNV_data: ", have_dqdt_SCNV_data + print*, "use_DCNV_scheme_sim: ", use_DCNV_scheme_sim + print*, " dTdt_DCNV_data: ", have_dTdt_DCNV_data + print*, " dudt_DCNV_data: ", have_dudt_DCNV_data + print*, " dvdt_DCNV_data: ", have_dvdt_DCNV_data + print*, " dqdt_DCNV_data: ", have_dqdt_DCNV_data + print*, "use_cldMP_scheme_sim: ", use_cldMP_scheme_sim + print*, " dTdt_cldMP_data: ", have_dTdt_cldMP_data + print*, " dqdt_cldMP_data: ", have_dqdt_cldMP_data + print*, "---------------------------------" + endif + + end subroutine ccpp_scheme_simultator_init + + ! ###################################################################################### + ! + ! SUBROUTINE ccpp_scheme_simultator_run + ! + ! ###################################################################################### +!! \section arg_table_ccpp_scheme_simultator_run +!! \htmlinclude ccpp_scheme_simultator_run.html +!! + subroutine ccpp_scheme_simultator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & + dtend, index_of_process_dcnv, index_of_process_longwave, & + index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gt0, gu0, gv0, gq0, & + errmsg, errflg) + + ! Inputs + integer, intent(in ) :: kdt + integer, intent (in), dimension(8) :: jdat + real(kind_phys), intent(in ) :: dtp, solhr + real(kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, dtend + integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_process_longwave, & + index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv + + ! Outputs + real(kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 + real(kind_phys), intent(inout), dimension(:,:,:) :: gq0 + character(len=*),intent(out ) :: errmsg + integer, intent(out ) :: errflg + + ! Locals + integer :: iCol, iLay, iTrc, nCol, nLay, nTrc, ti(1), tf(1), idtend, fcst_year, & + fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec + real(kind_phys) :: w1, w2,hrofday + real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1 + real(kind_phys), dimension(:,:,:), allocatable :: gq1 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. do_ccpp_scheme_simulator) return + + ! Current forecast time + fcst_year = jdat(1) + fcst_month = jdat(2) + fcst_day = jdat(3) + fcst_hour = jdat(5) + fcst_min = jdat(6) + fcst_sec = jdat(7) + + ! Dimensions + nCol = size(gq0(:,1,1)) + nLay = size(gq0(1,:,1)) + nTrc = size(gq0(1,1,:)) + + ! Allocate temporaries + allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) ! *only specific humidity to start (ntrc=1). + + ! Determine temporal interpolation weights for data-tendecies. + ! DJS: The data tendencies have a temporal dimension, to capture the diurnal cycle, + ! which is needed for reasonable solar forcing. + hrofday = fcst_hour*3600. + fcst_min*60. + fcst_sec + ti = findloc(abs(time_data-hrofday),minval(abs(time_data-hrofday))) + if (hrofday - time_data(ti(1)) .le. 0) ti = ti-1 + tf = ti + 1 + w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) + w2 = 1 - w1 + + do iCol = 1,nCol + ! Set state + gt1(iCol,:) = tgrs(iCol,:) + gu1(iCol,:) = ugrs(iCol,:) + gv1(iCol,:) = vgrs(iCol,:) + gq1(iCol,:,1) = qgrs(iCol,:,1) + + ! ############################################################################### + ! Radiation + ! ############################################################################### + if (use_RAD_scheme_sim) then + if (have_dTdt_LWRAD_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_LWRAD_data(:,ti(1)) + w2*dTdt_LWRAD_data(:,tf(1))) * dtp + endif + if (have_dTdt_SWRAD_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_SWRAD_data(:,ti(1)) + w2*dTdt_SWRAD_data(:,tf(1))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_longwave) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_temperature,index_of_process_shortwave) + if (idtend >=1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + endif + + ! ############################################################################### + ! PBL + ! ############################################################################### + if (use_PBL_scheme_sim) then + if (have_dTdt_PBL_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_PBL_data(:,ti(1)) + w2*(dTdt_PBL_data(:,tf(1)))) * dtp + endif + if (have_dudt_PBL_data) then + gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_PBL_data(:,ti(1)) + w2*(dudt_PBL_data(:,tf(1)))) * dtp + endif + if (have_dvdt_PBL_data) then + gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_PBL_data(:,ti(1)) + w2*(dvdt_PBL_data(:,tf(1)))) * dtp + endif + if (have_dqdt_PBL_data) then + gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_PBL_data(:,ti(1),1) + w2*(dqdt_PBL_data(:,tf(1),1))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_pbl) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_x_wind,index_of_process_pbl) + if (idtend >= 1) then + gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_y_wind,index_of_process_pbl) + if (idtend >= 1) then + gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(100+ntqv, index_of_process_pbl) + if (idtend >= 1) then + gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp + endif + endif + + ! ############################################################################### + ! Gravity wave drag + ! ############################################################################### + if (use_GWD_scheme_sim) then + if (have_dTdt_GWD_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_GWD_data(:,ti(1)) + w2*(dTdt_GWD_data(:,tf(1)))) * dtp + endif + if (have_dudt_GWD_data) then + gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_GWD_data(:,ti(1)) + w2*(dudt_GWD_data(:,tf(1)))) * dtp + endif + if (have_dvdt_GWD_data) then + gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_GWD_data(:,ti(1)) + w2*(dvdt_GWD_data(:,tf(1)))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_orographic_gwd) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_x_wind,index_of_process_orographic_gwd) + if (idtend >= 1) then + gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_y_wind,index_of_process_orographic_gwd) + if (idtend >= 1) then + gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + endif + + ! ############################################################################### + ! Shallow convection + ! ############################################################################### + if (use_SCNV_scheme_sim) then + if (have_dTdt_SCNV_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_SCNV_data(:,ti(1)) + w2*(dTdt_SCNV_data(:,tf(1)))) * dtp + endif + if (have_dudt_SCNV_data) then + gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_SCNV_data(:,ti(1)) + w2*(dudt_SCNV_data(:,tf(1)))) * dtp + endif + if (have_dvdt_SCNV_data) then + gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_SCNV_data(:,ti(1)) + w2*(dvdt_SCNV_data(:,tf(1)))) * dtp + endif + if (have_dqdt_SCNV_data) then + gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_SCNV_data(:,ti(1),1) + w2*(dqdt_SCNV_data(:,tf(1),1))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_scnv) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_x_wind,index_of_process_scnv) + if (idtend >= 1) then + gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_y_wind,index_of_process_scnv) + if (idtend >= 1) then + gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(100+ntqv,index_of_process_scnv) + if (idtend >= 1) then + gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp + endif + endif + + ! ############################################################################### + ! Deep convection + ! ############################################################################### + if (use_DCNV_scheme_sim) then + if (have_dTdt_DCNV_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_DCNV_data(:,ti(1)) + w2*(dTdt_DCNV_data(:,tf(1)) )) * dtp + endif + if (have_dudt_DCNV_data) then + gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_DCNV_data(:,ti(1)) + w2*(dudt_DCNV_data(:,tf(1)))) * dtp + endif + if (have_dvdt_DCNV_data) then + gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_DCNV_data(:,ti(1)) + w2*(dvdt_DCNV_data(:,tf(1)) )) * dtp + endif + if (have_dqdt_DCNV_data) then + gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_DCNV_data(:,ti(1),1) + w2*(dqdt_DCNV_data(:,tf(1),1))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_dcnv) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_x_wind,index_of_process_dcnv) + if (idtend >= 1) then + gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(index_of_y_wind,index_of_process_dcnv) + if (idtend >= 1) then + gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(100+ntqv,index_of_process_dcnv) + if (idtend >= 1) then + gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp + endif + endif + + ! ############################################################################### + ! Cloud microphysics + ! ############################################################################### + if (use_cldMP_scheme_sim) then + if (have_dTdt_cldMP_data) then + gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_cldMP_data(:,ti(1)) + w2*(dTdt_cldMP_data(:,tf(1)))) * dtp + endif + if (have_dqdt_cldMP_data) then + gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_cldMP_data(:,ti(1),1) + w2*(dqdt_cldMP_data(:,tf(1),1))) * dtp + endif + else + idtend = dtidx(index_of_temperature,index_of_process_mp) + if (idtend >= 1) then + gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp + endif + idtend = dtidx(100+ntqv,index_of_process_mp) + if (idtend >= 1) then + gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp + endif + endif + + enddo ! columns + ! + end subroutine ccpp_scheme_simultator_run + +end module ccpp_scheme_simultator diff --git a/physics/ccpp_scheme_simultator.meta b/physics/ccpp_scheme_simultator.meta new file mode 100644 index 000000000..e60248721 --- /dev/null +++ b/physics/ccpp_scheme_simultator.meta @@ -0,0 +1,266 @@ +[ccpp-table-properties] + name = ccpp_scheme_simultator + type = scheme + dependencies = machine.F + +######################################################################## +[ccpp-arg-table] + name = ccpp_scheme_simultator_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in +[nlunit] + standard_name = iounit_of_namelist + long_name = fortran unit number for opening nameliust file + units = none + dimensions = () + type = integer + intent = in +[nml_file] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in +[idat] + standard_name = date_and_time_at_model_initialization_in_iso_order + long_name = initialization date and time + units = none + dimensions = (8) + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = ccpp_scheme_simultator_run + type = scheme +[solhr] + standard_name = forecast_utc_hour + long_name = time in hours after 00z at the current timestep + units = h + dimensions = () + type = real + kind = kind_phys + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[jdat] + standard_name = date_and_time_of_forecast_in_united_states_order + long_name = current forecast date and time + units = none + dimensions = (8) + type = integer + intent = in +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[ugrs] + standard_name = x_wind + long_name = zonal wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[vgrs] + standard_name = y_wind + long_name = meridional wind + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[qgrs] + standard_name = tracer_concentration + long_name = model layer mean tracer concentration + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_longwave] + standard_name = index_of_longwave_heating_process_in_cumulative_change_index + long_name = index of longwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_shortwave] + standard_name = index_of_shortwave_heating_process_in_cumulative_change_index + long_name = index of shortwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_orographic_gwd] + standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_mp] + standard_name = index_of_microphysics_process_process_in_cumulative_change_index + long_name = index of microphysics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0] + standard_name = tracer_concentration_of_new_state + long_name = tracer concentration updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + type = real + kind = kind_phys + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file From f9abb735c0741eff2b79420f49082a5300fe46c9 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 30 Jan 2023 13:26:48 -0700 Subject: [PATCH 03/64] Fix file rename typo --- ...multator.F90 => ccpp_scheme_simulator.F90} | 26 +++++++++---------- ...ltator.meta => ccpp_scheme_simulator.meta} | 6 ++--- 2 files changed, 16 insertions(+), 16 deletions(-) rename physics/{ccpp_scheme_simultator.F90 => ccpp_scheme_simulator.F90} (96%) rename physics/{ccpp_scheme_simultator.meta => ccpp_scheme_simulator.meta} (98%) diff --git a/physics/ccpp_scheme_simultator.F90 b/physics/ccpp_scheme_simulator.F90 similarity index 96% rename from physics/ccpp_scheme_simultator.F90 rename to physics/ccpp_scheme_simulator.F90 index 4d53c8860..2954e3759 100644 --- a/physics/ccpp_scheme_simultator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -3,7 +3,7 @@ ! CCPP scheme to replace physics schemes with simulated data tendencies. ! ! ######################################################################################## -module ccpp_scheme_simultator +module ccpp_scheme_ccpp_scheme_simulator use machine, only: kind_phys use netcdf implicit none @@ -52,18 +52,18 @@ module ccpp_scheme_simultator ! Host-model initial time information integer :: init_year, init_month, init_day, init_hour, init_min, init_sec - public ccpp_scheme_simultator_init, ccpp_scheme_simultator_run + public ccpp_scheme_ccpp_scheme_simulator_init, ccpp_scheme_ccpp_scheme_simulator_run contains ! ###################################################################################### ! - ! SUBROUTINE ccpp_scheme_simultator_init + ! SUBROUTINE ccpp_scheme_ccpp_scheme_simulator_init ! ! ###################################################################################### -!! \section arg_table_ccpp_scheme_simultator_init -!! \htmlinclude ccpp_scheme_simultator_init.html +!! \section arg_table_ccpp_scheme_ccpp_scheme_simulator_init +!! \htmlinclude ccpp_scheme_ccpp_scheme_simulator_init.html !! - subroutine ccpp_scheme_simultator_init(me, master, nlunit, nml_file, idat, errmsg, errflg) + subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, idat, errmsg, errflg) ! Inputs integer, intent (in) :: me, master, nlunit @@ -331,17 +331,17 @@ subroutine ccpp_scheme_simultator_init(me, master, nlunit, nml_file, idat, errms print*, "---------------------------------" endif - end subroutine ccpp_scheme_simultator_init + end subroutine ccpp_scheme_ccpp_scheme_simulator_init ! ###################################################################################### ! - ! SUBROUTINE ccpp_scheme_simultator_run + ! SUBROUTINE ccpp_scheme_ccpp_scheme_simulator_run ! ! ###################################################################################### -!! \section arg_table_ccpp_scheme_simultator_run -!! \htmlinclude ccpp_scheme_simultator_run.html +!! \section arg_table_ccpp_scheme_ccpp_scheme_simulator_run +!! \htmlinclude ccpp_scheme_ccpp_scheme_simulator_run.html !! - subroutine ccpp_scheme_simultator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & + subroutine ccpp_scheme_ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & dtend, index_of_process_dcnv, index_of_process_longwave, & index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & @@ -588,6 +588,6 @@ subroutine ccpp_scheme_simultator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, q enddo ! columns ! - end subroutine ccpp_scheme_simultator_run + end subroutine ccpp_scheme_ccpp_scheme_simulator_run -end module ccpp_scheme_simultator +end module ccpp_scheme_ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simultator.meta b/physics/ccpp_scheme_simulator.meta similarity index 98% rename from physics/ccpp_scheme_simultator.meta rename to physics/ccpp_scheme_simulator.meta index e60248721..cad1bd7ed 100644 --- a/physics/ccpp_scheme_simultator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -1,11 +1,11 @@ [ccpp-table-properties] - name = ccpp_scheme_simultator + name = ccpp_scheme_ccpp_scheme_simulator type = scheme dependencies = machine.F ######################################################################## [ccpp-arg-table] - name = ccpp_scheme_simultator_init + name = ccpp_scheme_ccpp_scheme_simulator_init type = scheme [me] standard_name = mpi_rank @@ -61,7 +61,7 @@ ######################################################################## [ccpp-arg-table] - name = ccpp_scheme_simultator_run + name = ccpp_scheme_ccpp_scheme_simulator_run type = scheme [solhr] standard_name = forecast_utc_hour From ef0d369f607aa78908ac1a3687236ee7468f0fc6 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 31 Jan 2023 15:02:09 -0700 Subject: [PATCH 04/64] Added MPI commands to ccpp_scheme_simulator --- physics/ccpp_scheme_simulator.F90 | 534 ++++++++++++++++++++--------- physics/ccpp_scheme_simulator.meta | 17 +- 2 files changed, 382 insertions(+), 169 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 2954e3759..8289db769 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -3,9 +3,13 @@ ! CCPP scheme to replace physics schemes with simulated data tendencies. ! ! ######################################################################################## -module ccpp_scheme_ccpp_scheme_simulator +module ccpp_scheme_simulator use machine, only: kind_phys use netcdf +#ifdef MPI + use mpi +#endif + implicit none ! @@ -52,21 +56,21 @@ module ccpp_scheme_ccpp_scheme_simulator ! Host-model initial time information integer :: init_year, init_month, init_day, init_hour, init_min, init_sec - public ccpp_scheme_ccpp_scheme_simulator_init, ccpp_scheme_ccpp_scheme_simulator_run + public ccpp_scheme_simulator_init, ccpp_scheme_simulator_run contains ! ###################################################################################### ! - ! SUBROUTINE ccpp_scheme_ccpp_scheme_simulator_init + ! SUBROUTINE ccpp_scheme_simulator_init ! ! ###################################################################################### -!! \section arg_table_ccpp_scheme_ccpp_scheme_simulator_init -!! \htmlinclude ccpp_scheme_ccpp_scheme_simulator_init.html +!! \section arg_table_ccpp_scheme_simulator_init +!! \htmlinclude ccpp_scheme_simulator_init.html !! - subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, idat, errmsg, errflg) + subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, idat, errmsg, errflg) ! Inputs - integer, intent (in) :: me, master, nlunit + integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit character(len=*), intent (in) :: nml_file integer, intent (in), dimension(8) :: idat @@ -75,7 +79,7 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, integer, intent(out) :: errflg ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, nlev, ntime, ios + integer :: ncid, dimID, varID, status, nlon, nlat, nlev_data, ntime_data, ios character(len=256) :: fileIN logical :: exists integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality @@ -97,7 +101,11 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, init_min = idat(6) init_sec = idat(7) + ! ###################################################################################### + ! ! Read in namelist + ! + ! ###################################################################################### inquire (file = trim (nml_file), exist = exists) if (.not. exists) then errmsg = 'SCM data tendency :: namelist file: '//trim(nml_file)//' does not exist' @@ -110,6 +118,12 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, read (nlunit, nml = scm_data_nml) close (nlunit) + + ! ###################################################################################### + ! + ! Error checking + ! + ! ###################################################################################### ! Only proceed if scheme simulator requested. if (use_RAD_scheme_sim .or. use_PBL_scheme_sim .or. use_GWD_scheme_sim .or. & use_SCNV_scheme_sim .or. use_DCNV_scheme_sim .or. use_cldMP_scheme_sim) then @@ -126,180 +140,372 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, return endif - ! Open file (required) - status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) - if (status /= nf90_noerr) then - errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) - errflg = 1 - return - endif + ! ####################################################################################### + ! + ! Read mandatory information from data file... + ! (ONLY master processor(0), if MPI enabled) + ! + ! ####################################################################################### +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Open file (required) + status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) + errflg = 1 + return + endif + + ! Get dimensions (required) + status = nf90_inq_dimid(ncid, 'time', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [time] dimension' + errflg = 1 + return + endif + ! + status = nf90_inq_dimid(ncid, 'lev', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [lev] dimension' + errflg = 1 + return + endif +#ifdef MPI + endif ! On master processor - ! Get dimensions (required) - status = nf90_inq_dimid(ncid, 'time', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = ntime) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain time dimension' - errflg = 1 - return - endif + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! ####################################################################################### ! - status = nf90_inq_dimid(ncid, 'lev', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = nlev) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain lev dimension' - errflg = 1 - return - endif + ! Broadcast dimensions... + ! (ALL processors) + ! + ! ####################################################################################### + call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_barrier(mpicomm, mpierr) + + if (mpirank .eq. mpiroot) then +#endif + + ! #################################################################################### + ! + ! What data fields do we have? + ! + ! #################################################################################### + + ! Temporal info (required) + status = nf90_inq_varid(ncid, 'times', varID) + if (status /= nf90_noerr) then + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' + errflg = 1 + return + endif - ! Temporal info (required) - status = nf90_inq_varid(ncid, 'times', varID) - if (status == nf90_noerr) then - allocate(time_data(ntime)) - status = nf90_get_var( ncid, varID, time_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' - errflg = 1 - return - endif + ! Physics tendencies + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) then + have_dTdt_LWRAD_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) then + have_dTdt_SWRAD_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) then + have_dTdt_PBL_data = .true. + endif + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) then + have_dqdt_PBL_data = .true. + endif + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) then + have_dudt_PBL_data = .true. + endif + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) then + have_dvdt_PBL_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) then + have_dTdt_GWD_data = .true. + endif + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) then + have_dudt_GWD_data = .true. + endif + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) then + have_dvdt_GWD_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) then + have_dTdt_SCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) then + have_dudt_SCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) then + have_dvdt_SCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) then + have_dqdt_SCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) then + have_dTdt_DCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) then + have_dudt_DCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) then + have_dvdt_DCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) then + have_dqdt_DCNV_data = .true. + endif + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) then + have_dTdt_cldMP_data = .true. + endif + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) then + have_dqdt_cldMP_data = .true. + endif - ! Read in physics data tendencies (optional) - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) then - allocate(dTdt_LWRAD_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) - have_dTdt_LWRAD_data = .true. - endif +#ifdef MPI + endif ! Master process +#endif + + ! Allocate space for data + allocate(time_data(ntime_data)) + if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) + if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data, nTrc)) + if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) + if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) + if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) + if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) + if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) + if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) + if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) + if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) + if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) + if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) + if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) + if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) + if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data, nTrc)) + + ! ####################################################################################### ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) then - allocate(dTdt_SWRAD_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) - have_dTdt_SWRAD_data = .true. - endif + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) then - allocate(dTdt_PBL_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_PBL_data) - have_dTdt_PBL_data = .true. - endif + ! ####################################################################################### +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Temporal info (required) + status = nf90_inq_varid(ncid, 'times', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, time_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' + errflg = 1 + return + endif + + ! Read in physics data tendencies (optional) + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_PBL_data) + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dqdt_PBL_data) + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dudt_PBL_data) + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dvdt_PBL_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_GWD_data) + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dudt_GWD_data) + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dvdt_GWD_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_SCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dudt_SCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dvdt_SCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dqdt_SCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_DCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dudt_DCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dvdt_DCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dqdt_DCNV_data) + endif + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dTdt_cldMP_data) + endif + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, dqdt_cldMP_data) + endif + ! + status = nf90_close(ncid) +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + ! ####################################################################################### ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) then - allocate(dqdt_PBL_data(nlev, ntime, nTrc)) - status = nf90_get_var( ncid, varID, dqdt_PBL_data) - have_dqdt_PBL_data = .true. - endif + ! Broadcast data... + ! (ALL processors) ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) then - allocate(dudt_PBL_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dudt_PBL_data) - have_dudt_PBL_data = .true. + ! ####################################################################################### + + if (have_dTdt_LWRAD_data) then + call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) then - allocate(dvdt_PBL_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dvdt_PBL_data) - have_dvdt_PBL_data = .true. + if (have_dTdt_SWRAD_data) then + call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) then - allocate(dTdt_GWD_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_GWD_data) - have_dTdt_GWD_data = .true. + if (have_dTdt_PBL_data) then + call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) then - allocate(dudt_GWD_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dudt_GWD_data) - have_dudt_GWD_data = .true. + if (have_dqdt_PBL_data) then + call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) then - allocate(dvdt_GWD_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dvdt_GWD_data) - have_dvdt_GWD_data = .true. + if (have_dudt_PBL_data) then + call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) then - allocate(dTdt_SCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_SCNV_data) - have_dTdt_SCNV_data = .true. + if (have_dvdt_PBL_data) then + call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) then - allocate(dudt_SCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dudt_SCNV_data) - have_dudt_SCNV_data = .true. + if (have_dTdt_GWD_data) then + call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) then - allocate(dvdt_SCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dvdt_SCNV_data) - have_dvdt_SCNV_data = .true. + if (have_dudt_GWD_data) then + call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) then - allocate(dqdt_SCNV_data(nlev, ntime, nTrc)) - status = nf90_get_var( ncid, varID, dqdt_SCNV_data) - have_dqdt_SCNV_data = .true. + if (have_dvdt_GWD_data) then + call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) then - allocate(dTdt_DCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_DCNV_data) - have_dTdt_DCNV_data = .true. + if (have_dTdt_SCNV_data) then + call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) then - allocate(dudt_DCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dudt_DCNV_data) - have_dudt_DCNV_data = .true. + if (have_dudt_SCNV_data) then + call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) then - allocate(dvdt_DCNV_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dvdt_DCNV_data) - have_dvdt_DCNV_data = .true. + if (have_dvdt_SCNV_data) then + call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) then - allocate(dqdt_DCNV_data(nlev, ntime, nTrc)) - status = nf90_get_var( ncid, varID, dqdt_DCNV_data) - have_dqdt_DCNV_data = .true. + if (have_dqdt_SCNV_data) then + call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) then - allocate(dTdt_cldMP_data(nlev, ntime)) - status = nf90_get_var( ncid, varID, dTdt_cldMP_data) - have_dTdt_cldMP_data = .true. + if (have_dTdt_DCNV_data) then + call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) then - allocate(dqdt_cldMP_data(nlev, ntime, nTrc)) - status = nf90_get_var( ncid, varID, dqdt_cldMP_data) - have_dqdt_cldMP_data = .true. + if (have_dudt_DCNV_data) then + call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_DCNV_data) then + call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif + if (have_dqdt_DCNV_data) then + call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_cldMP_data) then + call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_cldMP_data) then + call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + + ! + call mpi_barrier(mpicomm, mpierr) +#endif ! - if (me == 0) then + if (mpirank .eq. mpiroot) then print*, "--- Using SCM data tendencies ---" print*, "---------------------------------" print*, " " @@ -331,17 +537,17 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_init(me, master, nlunit, nml_file, print*, "---------------------------------" endif - end subroutine ccpp_scheme_ccpp_scheme_simulator_init + end subroutine ccpp_scheme_simulator_init ! ###################################################################################### ! - ! SUBROUTINE ccpp_scheme_ccpp_scheme_simulator_run + ! SUBROUTINE ccpp_scheme_simulator_run ! ! ###################################################################################### -!! \section arg_table_ccpp_scheme_ccpp_scheme_simulator_run -!! \htmlinclude ccpp_scheme_ccpp_scheme_simulator_run.html +!! \section arg_table_ccpp_scheme_simulator_run +!! \htmlinclude ccpp_scheme_simulator_run.html !! - subroutine ccpp_scheme_ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & + subroutine ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & dtend, index_of_process_dcnv, index_of_process_longwave, & index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & @@ -588,6 +794,6 @@ subroutine ccpp_scheme_ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ug enddo ! columns ! - end subroutine ccpp_scheme_ccpp_scheme_simulator_run + end subroutine ccpp_scheme_simulator_run -end module ccpp_scheme_ccpp_scheme_simulator +end module ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index cad1bd7ed..909089bb9 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -1,26 +1,33 @@ [ccpp-table-properties] - name = ccpp_scheme_ccpp_scheme_simulator + name = ccpp_scheme_simulator type = scheme dependencies = machine.F ######################################################################## [ccpp-arg-table] - name = ccpp_scheme_ccpp_scheme_simulator_init + name = ccpp_scheme_simulator_init type = scheme -[me] +[mpirank] standard_name = mpi_rank long_name = MPI rank of current process units = index dimensions = () type = integer intent = in -[master] +[mpiroot] standard_name = mpi_root long_name = MPI rank of master process units = index dimensions = () type = integer intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in [nlunit] standard_name = iounit_of_namelist long_name = fortran unit number for opening nameliust file @@ -61,7 +68,7 @@ ######################################################################## [ccpp-arg-table] - name = ccpp_scheme_ccpp_scheme_simulator_run + name = ccpp_scheme_simulator_run type = scheme [solhr] standard_name = forecast_utc_hour From fd72b355bc99486bda0aff5d5a1c78f835756938 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Fri, 3 Feb 2023 10:27:05 -0700 Subject: [PATCH 05/64] Work in progress... --- physics/ccpp_scheme_simulator.F90 | 821 +++++++++++++++-------------- physics/ccpp_scheme_simulator.meta | 8 - 2 files changed, 416 insertions(+), 413 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 8289db769..258687416 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -2,6 +2,8 @@ ! ! CCPP scheme to replace physics schemes with simulated data tendencies. ! +! Description: +! ! ######################################################################################## module ccpp_scheme_simulator use machine, only: kind_phys @@ -9,50 +11,118 @@ module ccpp_scheme_simulator #ifdef MPI use mpi #endif - implicit none + ! Avaialble physics processes to simulate. + integer,parameter :: & + nPhysProcess = 7 + + ! Type containing physics tendencies for a physics process. + type phys_tend + real(kind_phys), dimension(:,:), pointer :: T + real(kind_phys), dimension(:,:), pointer :: u + real(kind_phys), dimension(:,:), pointer :: v + real(kind_phys), dimension(:,:,:), pointer :: q + end type phys_tend + + ! This type contains the meta information and data for each physics process. + type base_physics_process + character(len=16) :: name + logical :: time_split + logical :: use_sim + integer :: order + type(phys_tend) :: tend + end type base_physics_process + + ! This array contains the governing information on how to advance the physics timestep. + type(base_physics_process),dimension(nPhysProcess) :: & + physics_process + + ! ######################################################################################## + ! + ! Configuration for CCPP scheme simulator. Set in namelist. Used during initialization to + ! populate "physics_processes" type array. + ! + ! ######################################################################################## + + ! Set which schemes to be replaced with simulated tendencies. + logical :: use_LWRAD_scheme_sim = .false., & !< If true, use LongWave RADiation scheme simulator. + !< If false, use tendencies from radiation scheme. + use_SWRAD_scheme_sim = .false., & !< If true, use ShortWave RADiation scheme simulator. + !< If false, use tendencies from radiation scheme. + use_PBL_scheme_sim = .false., & !< If true, use Planetary Boubdary Layer scheme simulator. + !< If false, use tendencies from PBL scheme. + use_GWD_scheme_sim = .false., & !< If true, use Gravity Wave Drag scheme simulator. + !< If false, use tendencies from GWD scheme. + use_SCNV_scheme_sim = .false., & !< If true, use Shallow CoNVection scheme simulator. + !< If false, use tendencies from SCNV scheme. + use_DCNV_scheme_sim = .false., & !< If true, use Deep CoNVection scheme simulator. + !< If false, use tendencies from DCNV scheme. + use_cldMP_scheme_sim = .false. !< If true, use cloud MicroPhysics scheme simulator. + !< If false, use tendencies from cldMP acheme. + + ! Are the processes time-split or process-split? + logical :: time_split_LWRAD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_SWRAD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_PBL = .false., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_GWD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_SCNV = .true., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_DCNV = .true., & !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + time_split_cldMP = .true. !< If true, time-split process. Update internal physics state prior to scheme. + !< If false, process-split process. Accumulate tendencies. + + ! What is physics process ordering? (Important if their are time-split processes in the physics scheme) + integer :: scheme_order_SWRAD = 1, & !< Order of Radiation scheme (shortwave). + scheme_order_LWRAD = 2, & !< Order of Radiation scheme (longwave). + scheme_order_PBL = 3, & !< Order of Planetary Boubdary Layer scheme. + scheme_order_GWD = 4, & !< Order of Gravity Wave Drag scheme. + scheme_order_SCNV = 5, & !< Order of Shallow CoNVection scheme. + scheme_order_DCNV = 6, & !< Order of Deep CoNVection scheme. + scheme_order_cldMP = 7 !< Order of cloud MicroPhysics scheme. ! - ! Data driven phsyics tendencies + ! Locals ! + + ! Activation flag for scheme. + logical :: do_ccpp_scheme_simulator = .false. + + ! Switches for input data + logical :: have_dTdt_LWRAD_data = .false., & !< If true, input file contains LongWave RADiation temperature tendencies. + have_dTdt_SWRAD_data = .false., & !< If true, input file contains ShortWave RADiation temperature tendencies. + have_dTdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer temperature tendencies. + have_dqdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer specific-humidity tendencies. + have_dudt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer zonal-wind tendencies. + have_dvdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer meridional-wind tendencies. + have_dTdt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag temperature tendencies. + have_dudt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag zonal-wind tendencies. + have_dvdt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag meridional-wind tendencies. + have_dTdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection temperature tendencies. + have_dudt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection zonal-wind tendencies. + have_dvdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection meridional-wind tendencies. + have_dqdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection specific-humidity tendencies. + have_dTdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection temperature tendencies. + have_dudt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection zonal-wind tendencies. + have_dvdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection meridional-wind tendencies. + have_dqdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection specific-humidity tendencies. + have_dTdt_cldMP_data = .false., & !< If true, input file contains cloud MicroPhysics temperature tendencies. + have_dqdt_cldMP_data = .false. !< If true, input file contains cloud MicroPhysics specific-humidity tendencies. + + ! Data driven physics tendencies + integer :: nlev_data, ntime_data real(kind_phys), allocatable, dimension(:) :: time_data - real(kind_phys), allocatable, dimension(:,:) :: dTdt_LWRAD_data, dTdt_SWRAD_data, & + real(kind_phys), allocatable, dimension(:,:),target :: dTdt_LWRAD_data, dTdt_SWRAD_data, & dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, dudt_GWD_data, & dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, dTdt_DCNV_data, & dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:,:) :: dqdt_PBL_data, dqdt_SCNV_data, & + real(kind_phys), allocatable, dimension(:,:,:),target :: dqdt_PBL_data, dqdt_SCNV_data, & dqdt_DCNV_data, dqdt_cldMP_data - ! - ! Logical switches for CCPP scheme simulator(s) - ! - logical :: use_RAD_scheme_sim = .false., & - use_PBL_scheme_sim = .false., & - use_GWD_scheme_sim = .false., & - use_SCNV_scheme_sim = .false., & - use_DCNV_scheme_sim = .false., & - use_cldMP_scheme_sim = .false. - logical :: have_dTdt_LWRAD_data = .false., & - have_dTdt_SWRAD_data = .false., & - have_dTdt_PBL_data = .false., & - have_dqdt_PBL_data = .false., & - have_dudt_PBL_data = .false., & - have_dvdt_PBL_data = .false., & - have_dTdt_GWD_data = .false., & - have_dudt_GWD_data = .false., & - have_dvdt_GWD_data = .false., & - have_dTdt_SCNV_data = .false., & - have_dudt_SCNV_data = .false., & - have_dvdt_SCNV_data = .false., & - have_dqdt_SCNV_data = .false., & - have_dTdt_DCNV_data = .false., & - have_dudt_DCNV_data = .false., & - have_dvdt_DCNV_data = .false., & - have_dqdt_DCNV_data = .false., & - have_dTdt_cldMP_data = .false., & - have_dqdt_cldMP_data = .false. - logical :: do_ccpp_scheme_simulator = .false. - ! Host-model initial time information integer :: init_year, init_month, init_day, init_hour, init_min, init_sec @@ -67,7 +137,8 @@ module ccpp_scheme_simulator !! \section arg_table_ccpp_scheme_simulator_init !! \htmlinclude ccpp_scheme_simulator_init.html !! - subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, idat, errmsg, errflg) + subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, & + idat, errmsg, errflg) ! Inputs integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit @@ -79,15 +150,19 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil integer, intent(out) :: errflg ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, nlev_data, ntime_data, ios + integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc character(len=256) :: fileIN logical :: exists integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality ! Namelist - namelist / scm_data_nml / & - fileIN, use_RAD_scheme_sim, use_PBL_scheme_sim, use_GWD_scheme_sim, use_SCNV_scheme_sim, & - use_DCNV_scheme_sim, use_cldMP_scheme_sim + namelist / scm_data_nml / fileIN, & + use_SWRAD_scheme_sim, use_LWRAD_scheme_sim, use_PBL_scheme_sim, & + use_GWD_scheme_sim, use_SCNV_scheme_sim, use_DCNV_scheme_sim, & + use_cldMP_scheme_sim, scheme_order_SWRAD, scheme_order_LWRAD, scheme_order_PBL, & + scheme_order_GWD, scheme_order_SCNV, scheme_order_DCNV, scheme_order_cldMP, & + time_split_SWRAD, time_split_LWRAD, time_split_PBL, time_split_GWD, & + time_split_SCNV, time_split_DCNV, time_split_cldMP ! Initialize CCPP error handling variables errmsg = '' @@ -118,27 +193,27 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil read (nlunit, nml = scm_data_nml) close (nlunit) - ! ###################################################################################### ! ! Error checking ! ! ###################################################################################### ! Only proceed if scheme simulator requested. - if (use_RAD_scheme_sim .or. use_PBL_scheme_sim .or. use_GWD_scheme_sim .or. & - use_SCNV_scheme_sim .or. use_DCNV_scheme_sim .or. use_cldMP_scheme_sim) then + if (use_SWRAD_scheme_sim .or. use_LWRAD_scheme_sim .or. use_PBL_scheme_sim .or. & + use_GWD_scheme_sim .or. use_SCNV_scheme_sim .or. use_DCNV_scheme_sim .or. & + use_cldMP_scheme_sim) then do_ccpp_scheme_simulator = .true. else return endif - + ! Check that input data file exists inquire (file = trim (fileIN), exist = exists) if (.not. exists) then - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' - errflg = 1 - return - endif + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' + errflg = 1 + return + endif ! ####################################################################################### ! @@ -201,91 +276,63 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil ! ! #################################################################################### - ! Temporal info (required) - status = nf90_inq_varid(ncid, 'times', varID) - if (status /= nf90_noerr) then - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' - errflg = 1 - return - endif - - ! Physics tendencies + ! status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) then - have_dTdt_LWRAD_data = .true. - endif + if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) then - have_dTdt_SWRAD_data = .true. - endif + if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) then - have_dTdt_PBL_data = .true. - endif + if (status == nf90_noerr) have_dTdt_PBL_data = .true. + ! status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) then - have_dqdt_PBL_data = .true. - endif + if (status == nf90_noerr) have_dqdt_PBL_data = .true. + ! status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) then - have_dudt_PBL_data = .true. - endif + if (status == nf90_noerr) have_dudt_PBL_data = .true. + ! status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) then - have_dvdt_PBL_data = .true. - endif + if (status == nf90_noerr) have_dvdt_PBL_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) then - have_dTdt_GWD_data = .true. - endif + if (status == nf90_noerr) have_dTdt_GWD_data = .true. + ! status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) then - have_dudt_GWD_data = .true. - endif + if (status == nf90_noerr) have_dudt_GWD_data = .true. + ! status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) then - have_dvdt_GWD_data = .true. - endif + if (status == nf90_noerr) have_dvdt_GWD_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) then - have_dTdt_SCNV_data = .true. - endif + if (status == nf90_noerr) have_dTdt_SCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) then - have_dudt_SCNV_data = .true. - endif + if (status == nf90_noerr) have_dudt_SCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) then - have_dvdt_SCNV_data = .true. - endif + if (status == nf90_noerr) have_dvdt_SCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) then - have_dqdt_SCNV_data = .true. - endif + if (status == nf90_noerr) have_dqdt_SCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) then - have_dTdt_DCNV_data = .true. - endif + if (status == nf90_noerr) have_dTdt_DCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) then - have_dudt_DCNV_data = .true. - endif + if (status == nf90_noerr) have_dudt_DCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) then - have_dvdt_DCNV_data = .true. - endif + if (status == nf90_noerr) have_dvdt_DCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) then - have_dqdt_DCNV_data = .true. - endif + if (status == nf90_noerr) have_dqdt_DCNV_data = .true. + ! status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) then - have_dTdt_cldMP_data = .true. - endif + if (status == nf90_noerr) have_dTdt_cldMP_data = .true. + ! status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) then - have_dqdt_cldMP_data = .true. - endif + if (status == nf90_noerr) have_dqdt_cldMP_data = .true. #ifdef MPI endif ! Master process @@ -335,101 +382,64 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil ! Read in physics data tendencies (optional) status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) ! status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) ! status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_PBL_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) ! status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dqdt_PBL_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) ! status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dudt_PBL_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) ! status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dvdt_PBL_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) ! status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_GWD_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) ! status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dudt_GWD_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) ! status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dvdt_GWD_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) ! status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_SCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) ! status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dudt_SCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) ! status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dvdt_SCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) ! status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dqdt_SCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) ! status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_DCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) ! status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dudt_DCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) ! status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dvdt_DCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) ! status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dqdt_DCNV_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) ! status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dTdt_cldMP_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) ! status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, dqdt_cldMP_data) - endif + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) ! status = nf90_close(ncid) + #ifdef MPI endif ! Master process @@ -449,49 +459,49 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dTdt_PBL_data) then - call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dqdt_PBL_data) then - call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dudt_PBL_data) then - call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dvdt_PBL_data) then - call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dTdt_GWD_data) then - call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dudt_GWD_data) then - call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dvdt_GWD_data) then - call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dTdt_SCNV_data) then - call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dudt_SCNV_data) then - call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dvdt_SCNV_data) then - call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dqdt_SCNV_data) then - call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dTdt_DCNV_data) then - call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dudt_DCNV_data) then - call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dvdt_DCNV_data) then - call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dqdt_DCNV_data) then - call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif if (have_dTdt_cldMP_data) then call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) @@ -499,41 +509,94 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil if (have_dqdt_cldMP_data) then call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) endif - ! call mpi_barrier(mpicomm, mpierr) #endif + ! ####################################################################################### + ! + ! Populate physics_process type. + ! + ! ####################################################################################### + + ! Metadata + do iprc = 1,nPhysProcess + if (iprc == scheme_order_SWRAD) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SWRAD" + physics_process(iprc)%use_sim = use_SWRAD_scheme_sim + physics_process(iprc)%time_split = time_split_SWRAD + endif + if (iprc == scheme_order_LWRAD) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "LWRAD" + physics_process(iprc)%use_sim = use_LWRAD_scheme_sim + physics_process(iprc)%time_split = time_split_LWRAD + endif + if (iprc == scheme_order_GWD) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "GWD" + physics_process(iprc)%use_sim = use_GWD_scheme_sim + physics_process(iprc)%time_split = time_split_GWD + endif + if (iprc == scheme_order_PBL) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "PBL" + physics_process(iprc)%use_sim = use_PBL_scheme_sim + physics_process(iprc)%time_split = time_split_PBL + endif + if (iprc == scheme_order_SCNV) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SCNV" + physics_process(iprc)%use_sim = use_SCNV_scheme_sim + physics_process(iprc)%time_split = time_split_SCNV + endif + if (iprc == scheme_order_DCNV) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "DCNV" + physics_process(iprc)%use_sim = use_DCNV_scheme_sim + physics_process(iprc)%time_split = time_split_DCNV + endif + if (iprc == scheme_order_cldMP) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "cldMP" + physics_process(iprc)%use_sim = use_cldMP_scheme_sim + physics_process(iprc)%time_split = time_split_cldMP + endif + enddo + + ! Data + if (have_dTdt_LWRAD_data) physics_process(scheme_order_LWRAD)%tend%T => dTdt_LWRAD_data + if (have_dTdt_SWRAD_data) physics_process(scheme_order_SWRAD)%tend%T => dTdt_SWRAD_data + if (have_dTdt_PBL_data) physics_process(scheme_order_PBL)%tend%T => dTdt_PBL_data + if (have_dudt_PBL_data) physics_process(scheme_order_PBL)%tend%u => dudt_PBL_data + if (have_dvdt_PBL_data) physics_process(scheme_order_PBL)%tend%v => dvdt_PBL_data + if (have_dqdt_PBL_data) physics_process(scheme_order_PBL)%tend%q => dqdt_PBL_data + if (have_dTdt_GWD_data) physics_process(scheme_order_GWD)%tend%T => dTdt_GWD_data + if (have_dudt_GWD_data) physics_process(scheme_order_GWD)%tend%u => dudt_GWD_data + if (have_dvdt_GWD_data) physics_process(scheme_order_GWD)%tend%v => dvdt_GWD_data + if (have_dTdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%T => dTdt_SCNV_data + if (have_dudt_SCNV_data) physics_process(scheme_order_SCNV)%tend%u => dudt_SCNV_data + if (have_dvdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%v => dvdt_SCNV_data + if (have_dqdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%q => dqdt_SCNV_data + if (have_dTdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%T => dTdt_DCNV_data + if (have_dudt_DCNV_data) physics_process(scheme_order_DCNV)%tend%u => dudt_DCNV_data + if (have_dvdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%v => dvdt_DCNV_data + if (have_dqdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%q => dqdt_DCNV_data + if (have_dTdt_cldMP_data) physics_process(scheme_order_cldMP)%tend%T => dTdt_cldMP_data + if (have_dqdt_cldMP_data) physics_process(scheme_order_cldMP)%tend%q => dqdt_cldMP_data + ! if (mpirank .eq. mpiroot) then - print*, "--- Using SCM data tendencies ---" + print*, "--- Using CCPP data tendencies ---" print*, "---------------------------------" print*, " " - print*, "use_RAD_scheme_sim: ", use_RAD_scheme_sim - print*, " dTdt_LWRAD_data: ", have_dTdt_LWRAD_data - print*, " dTdt_SWRAD_data: ", have_dTdt_SWRAD_data - print*, "use_PBL_scheme_sim: ", use_PBL_scheme_sim - print*, " dTdt_PBL_data: ", have_dTdt_PBL_data - print*, " dqdt_PBL_data: ", have_dqdt_PBL_data - print*, " dudt_PBL_data: ", have_dudt_PBL_data - print*, " dvdt_PBL_data: ", have_dvdt_PBL_data - print*, "use_GWD_scheme_sim: ", use_GWD_scheme_sim - print*, " dTdt_gwd_data: ", have_dTdt_GWD_data - print*, " dudt_gwd_data: ", have_dudt_GWD_data - print*, " dvdt_gwd_data: ", have_dvdt_GWD_data - print*, "use_SCNV_scheme_sim: ", use_SCNV_scheme_sim - print*, " dTdt_SCNV_data: ", have_dTdt_SCNV_data - print*, " dudt_SCNV_data: ", have_dudt_SCNV_data - print*, " dvdt_SCNV_data: ", have_dvdt_SCNV_data - print*, " dqdt_SCNV_data: ", have_dqdt_SCNV_data - print*, "use_DCNV_scheme_sim: ", use_DCNV_scheme_sim - print*, " dTdt_DCNV_data: ", have_dTdt_DCNV_data - print*, " dudt_DCNV_data: ", have_dudt_DCNV_data - print*, " dvdt_DCNV_data: ", have_dvdt_DCNV_data - print*, " dqdt_DCNV_data: ", have_dqdt_DCNV_data - print*, "use_cldMP_scheme_sim: ", use_cldMP_scheme_sim - print*, " dTdt_cldMP_data: ", have_dTdt_cldMP_data - print*, " dqdt_cldMP_data: ", have_dqdt_cldMP_data + do iprc = 1,nPhysProcess + print*,"Process : ", trim(physics_process(iprc)%name) + print*," order : ", physics_process(iprc)%order + print*," use_sim : ", physics_process(iprc)%use_sim + print*," time_split : ", physics_process(iprc)%time_split + enddo print*, "---------------------------------" endif @@ -547,7 +610,7 @@ end subroutine ccpp_scheme_simulator_init !! \section arg_table_ccpp_scheme_simulator_run !! \htmlinclude ccpp_scheme_simulator_run.html !! - subroutine ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & + subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & dtend, index_of_process_dcnv, index_of_process_longwave, & index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & @@ -555,28 +618,29 @@ subroutine ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qg errmsg, errflg) ! Inputs - integer, intent(in ) :: kdt - integer, intent (in), dimension(8) :: jdat - real(kind_phys), intent(in ) :: dtp, solhr - real(kind_phys), intent(in ), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs, dtend - integer, intent(in) :: dtidx(:,:), index_of_process_dcnv, index_of_process_longwave, & - index_of_process_shortwave, index_of_process_scnv, & + integer, intent(in) :: kdt, ntqv, index_of_process_dcnv, & + index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv + index_of_temperature, index_of_x_wind, index_of_y_wind + integer, intent(in), dimension(8) :: jdat + integer, intent(in), dimension(:,:) :: dtidx + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in), dimension(:,:) :: tgrs, ugrs, vgrs + real(kind_phys), intent(in), dimension(:,:,:) :: qgrs, dtend ! Outputs real(kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 real(kind_phys), intent(inout), dimension(:,:,:) :: gq0 - character(len=*),intent(out ) :: errmsg - integer, intent(out ) :: errflg + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg ! Locals integer :: iCol, iLay, iTrc, nCol, nLay, nTrc, ti(1), tf(1), idtend, fcst_year, & - fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec + fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, iprc, index_of_process real(kind_phys) :: w1, w2,hrofday - real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1 - real(kind_phys), dimension(:,:,:), allocatable :: gq1 + real(kind_phys), dimension(:), allocatable :: dT, du, dv, dq + real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt + real(kind_phys), dimension(:,:,:), allocatable :: gq1, dqdt ! Initialize CCPP error handling variables errmsg = '' @@ -596,9 +660,11 @@ subroutine ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qg nCol = size(gq0(:,1,1)) nLay = size(gq0(1,:,1)) nTrc = size(gq0(1,1,:)) - + ! Allocate temporaries allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) ! *only specific humidity to start (ntrc=1). + allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) + allocate(dT(nLay), du(nLay), dv(nLay), dq(nLay)) ! Determine temporal interpolation weights for data-tendecies. ! DJS: The data tendencies have a temporal dimension, to capture the diurnal cycle, @@ -610,190 +676,135 @@ subroutine ccpp_scheme_simulator_run(solhr, kdt, dtp, jdat, tgrs, ugrs, vgrs, qg w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) w2 = 1 - w1 - do iCol = 1,nCol - ! Set state - gt1(iCol,:) = tgrs(iCol,:) - gu1(iCol,:) = ugrs(iCol,:) - gv1(iCol,:) = vgrs(iCol,:) - gq1(iCol,:,1) = qgrs(iCol,:,1) - - ! ############################################################################### - ! Radiation - ! ############################################################################### - if (use_RAD_scheme_sim) then - if (have_dTdt_LWRAD_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_LWRAD_data(:,ti(1)) + w2*dTdt_LWRAD_data(:,tf(1))) * dtp - endif - if (have_dTdt_SWRAD_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_SWRAD_data(:,ti(1)) + w2*dTdt_SWRAD_data(:,tf(1))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_longwave) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_temperature,index_of_process_shortwave) - if (idtend >=1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - endif + ! + ! DJS BEGIN: This section will, eventually, replace the icol loop below, using the physics_process type. + ! - ! ############################################################################### - ! PBL - ! ############################################################################### - if (use_PBL_scheme_sim) then - if (have_dTdt_PBL_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_PBL_data(:,ti(1)) + w2*(dTdt_PBL_data(:,tf(1)))) * dtp - endif - if (have_dudt_PBL_data) then - gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_PBL_data(:,ti(1)) + w2*(dudt_PBL_data(:,tf(1)))) * dtp - endif - if (have_dvdt_PBL_data) then - gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_PBL_data(:,ti(1)) + w2*(dvdt_PBL_data(:,tf(1)))) * dtp - endif - if (have_dqdt_PBL_data) then - gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_PBL_data(:,ti(1),1) + w2*(dqdt_PBL_data(:,tf(1),1))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_pbl) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_x_wind,index_of_process_pbl) - if (idtend >= 1) then - gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_y_wind,index_of_process_pbl) - if (idtend >= 1) then - gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(100+ntqv, index_of_process_pbl) - if (idtend >= 1) then - gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp + ! Set state + gt1(:,:) = tgrs(:,:) + gu1(:,:) = ugrs(:,:) + gv1(:,:) = vgrs(:,:) + gq1(:,:,1) = qgrs(:,:,1) + dTdt(:,:) = 0. + dudt(:,:) = 0. + dvdt(:,:) = 0. + dqdt(:,:,1)= 0. + do iCol = 1,nCol + do iprc = 1,nPhysProcess + + ! Using scheme simulator + if (physics_process(iprc)%use_sim) then + print*,"Using CCPP scheme simulator for ",trim(physics_process(iprc)%name) + + ! Temperature + if (associated(physics_process(iprc)%tend%T)) then + call interp_data_tend("T", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dT) + endif + + ! Zonal-wind + if (associated(physics_process(iprc)%tend%u)) then + call interp_data_tend("u", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, du) + endif + + ! Meridional-wind + if (associated(physics_process(iprc)%tend%v)) then + call interp_data_tend("v", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dv) + endif + + ! Specific-humidity + if (associated(physics_process(iprc)%tend%q)) then + call interp_data_tend("q", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dq) + endif + + ! Using data tendency from "active" scheme(s). + else + print*,"ACTIVE PHYSICS SCHEME: ",trim(physics_process(iprc)%name) + if (physics_process(iprc)%name == "LWRAD") index_of_process = index_of_process_longwave + if (physics_process(iprc)%name == "SWRAD") index_of_process = index_of_process_shortwave + if (physics_process(iprc)%name == "PBL") index_of_process = index_of_process_pbl + if (physics_process(iprc)%name == "GWD") index_of_process = index_of_process_orographic_gwd + if (physics_process(iprc)%name == "SCNV") index_of_process = index_of_process_scnv + if (physics_process(iprc)%name == "DCNV") index_of_process = index_of_process_dcnv + if (physics_process(iprc)%name == "cldMP") index_of_process = index_of_process_mp + ! + idtend = dtidx(index_of_temperature,index_of_process) + if (idtend >= 1) dT = dtend(iCol,:,idtend) + ! + idtend = dtidx(index_of_x_wind,index_of_process) + if (idtend >= 1) du = dtend(iCol,:,idtend) + ! + idtend = dtidx(index_of_y_wind,index_of_process) + if (idtend >= 1) dv = dtend(iCol,:,idtend) + ! + idtend = dtidx(100+ntqv,index_of_process) + if (idtend >= 1) dq = dtend(iCol,:,idtend) endif - endif + + ! Update state now? + if (physics_process(iprc)%time_split) then + gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + dT)*dtp + gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + du)*dtp + gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + dv)*dtp + gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + dq)*dtp + dTdt(iCol,:) = 0. + dudt(iCol,:) = 0. + dvdt(iCol,:) = 0. + dqdt(iCol,:,1) = 0. + ! Accumulate tendencies, update later? + else + dTdt(iCol,:) = dTdt(iCol,:) + dT + dudt(iCol,:) = dudt(iCol,:) + du + dvdt(iCol,:) = dvdt(iCol,:) + dv + dqdt(iCol,:,1) = dqdt(iCol,:,1) + dq + endif + enddo + ! + gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp + gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp + gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp + gq0(iCol,:,1) = gq1(iCol,:,1) + dqdt(iCol,:,1)*dtp + enddo + ! + end subroutine ccpp_scheme_simulator_run - ! ############################################################################### - ! Gravity wave drag - ! ############################################################################### - if (use_GWD_scheme_sim) then - if (have_dTdt_GWD_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_GWD_data(:,ti(1)) + w2*(dTdt_GWD_data(:,tf(1)))) * dtp - endif - if (have_dudt_GWD_data) then - gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_GWD_data(:,ti(1)) + w2*(dudt_GWD_data(:,tf(1)))) * dtp - endif - if (have_dvdt_GWD_data) then - gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_GWD_data(:,ti(1)) + w2*(dvdt_GWD_data(:,tf(1)))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_orographic_gwd) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_x_wind,index_of_process_orographic_gwd) - if (idtend >= 1) then - gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_y_wind,index_of_process_orographic_gwd) - if (idtend >= 1) then - gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - endif + ! #################################################################################### + ! Utility functions/routines + ! #################################################################################### + subroutine interp_data_tend(var_name, process_name, iprc, year, month, day, hour, minute, & + second, var_out) + ! Inputs + character(len=*), intent(in) :: var_name, process_name + integer, intent(in) :: year, month, day, hour, minute, second, iprc + + ! Outputs + real(kind_phys),dimension(:),intent(out) :: var_out - ! ############################################################################### - ! Shallow convection - ! ############################################################################### - if (use_SCNV_scheme_sim) then - if (have_dTdt_SCNV_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_SCNV_data(:,ti(1)) + w2*(dTdt_SCNV_data(:,tf(1)))) * dtp - endif - if (have_dudt_SCNV_data) then - gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_SCNV_data(:,ti(1)) + w2*(dudt_SCNV_data(:,tf(1)))) * dtp - endif - if (have_dvdt_SCNV_data) then - gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_SCNV_data(:,ti(1)) + w2*(dvdt_SCNV_data(:,tf(1)))) * dtp - endif - if (have_dqdt_SCNV_data) then - gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_SCNV_data(:,ti(1),1) + w2*(dqdt_SCNV_data(:,tf(1),1))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_scnv) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_x_wind,index_of_process_scnv) - if (idtend >= 1) then - gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_y_wind,index_of_process_scnv) - if (idtend >= 1) then - gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(100+ntqv,index_of_process_scnv) - if (idtend >= 1) then - gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp - endif - endif + ! Locals + integer :: ti(1), tf(1) + real(kind_phys) :: w1, w2, hrofday - ! ############################################################################### - ! Deep convection - ! ############################################################################### - if (use_DCNV_scheme_sim) then - if (have_dTdt_DCNV_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_DCNV_data(:,ti(1)) + w2*(dTdt_DCNV_data(:,tf(1)) )) * dtp - endif - if (have_dudt_DCNV_data) then - gu1(iCol,:) = gu1(iCol,:) + (w1*dudt_DCNV_data(:,ti(1)) + w2*(dudt_DCNV_data(:,tf(1)))) * dtp - endif - if (have_dvdt_DCNV_data) then - gv1(iCol,:) = gv1(iCol,:) + (w1*dvdt_DCNV_data(:,ti(1)) + w2*(dvdt_DCNV_data(:,tf(1)) )) * dtp - endif - if (have_dqdt_DCNV_data) then - gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_DCNV_data(:,ti(1),1) + w2*(dqdt_DCNV_data(:,tf(1),1))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_dcnv) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_x_wind,index_of_process_dcnv) - if (idtend >= 1) then - gu1(iCol,:) = gu1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(index_of_y_wind,index_of_process_dcnv) - if (idtend >= 1) then - gv1(iCol,:) = gv1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(100+ntqv,index_of_process_dcnv) - if (idtend >= 1) then - gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp - endif - endif + hrofday = hour*3600. + minute*60. + second + ti = findloc(abs(time_data-hrofday),minval(abs(time_data-hrofday))) + if (hrofday - time_data(ti(1)) .le. 0) ti = ti-1 + tf = ti + 1 + w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) + w2 = 1 - w1 - ! ############################################################################### - ! Cloud microphysics - ! ############################################################################### - if (use_cldMP_scheme_sim) then - if (have_dTdt_cldMP_data) then - gt1(iCol,:) = gt1(iCol,:) + (w1*dTdt_cldMP_data(:,ti(1)) + w2*(dTdt_cldMP_data(:,tf(1)))) * dtp - endif - if (have_dqdt_cldMP_data) then - gq1(iCol,:,1) = gq1(iCol,:,1) + (w1*dqdt_cldMP_data(:,ti(1),1) + w2*(dqdt_cldMP_data(:,tf(1),1))) * dtp - endif - else - idtend = dtidx(index_of_temperature,index_of_process_mp) - if (idtend >= 1) then - gt1(iCol,:) = gt1(iCol,:) + dtend(iCol,:,idtend)! * dtp - endif - idtend = dtidx(100+ntqv,index_of_process_mp) - if (idtend >= 1) then - gq1(iCol,:,1) = gq1(iCol,:,1) + dtend(iCol,:,idtend)! * dtp - endif - endif + if (var_name == "T") then + var_out = w1*physics_process(iprc)%tend%T(:,ti(1)) + w2*physics_process(iprc)%tend%T(:,tf(1)) + endif - enddo ! columns - ! - end subroutine ccpp_scheme_simulator_run + if (var_name == "u") then + var_out = w1*physics_process(iprc)%tend%u(:,ti(1)) + w2*physics_process(iprc)%tend%u(:,tf(1)) + endif + + if (var_name == "v") then + var_out = w1*physics_process(iprc)%tend%v(:,ti(1)) + w2*physics_process(iprc)%tend%v(:,tf(1)) + endif + + if (var_name == "q") then + var_out = w1*physics_process(iprc)%tend%q(:,ti(1),1) + w2*physics_process(iprc)%tend%q(:,tf(1),1) + endif + end subroutine interp_data_tend end module ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 909089bb9..92e39ff61 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -70,14 +70,6 @@ [ccpp-arg-table] name = ccpp_scheme_simulator_run type = scheme -[solhr] - standard_name = forecast_utc_hour - long_name = time in hours after 00z at the current timestep - units = h - dimensions = () - type = real - kind = kind_phys - intent = in [kdt] standard_name = index_of_timestep long_name = current forecast iteration From ffd26ab39759091969c23995dfc051c077b330c6 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 6 Feb 2023 10:55:30 -0700 Subject: [PATCH 06/64] Some changes --- physics/ccpp_scheme_simulator.F90 | 42 +++++++++++++++---------------- 1 file changed, 20 insertions(+), 22 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 258687416..be7ad03f9 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -666,20 +666,6 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) allocate(dT(nLay), du(nLay), dv(nLay), dq(nLay)) - ! Determine temporal interpolation weights for data-tendecies. - ! DJS: The data tendencies have a temporal dimension, to capture the diurnal cycle, - ! which is needed for reasonable solar forcing. - hrofday = fcst_hour*3600. + fcst_min*60. + fcst_sec - ti = findloc(abs(time_data-hrofday),minval(abs(time_data-hrofday))) - if (hrofday - time_data(ti(1)) .le. 0) ti = ti-1 - tf = ti + 1 - w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) - w2 = 1 - w1 - - ! - ! DJS BEGIN: This section will, eventually, replace the icol loop below, using the physics_process type. - ! - ! Set state gt1(:,:) = tgrs(:,:) gu1(:,:) = ugrs(:,:) @@ -689,8 +675,13 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dudt(:,:) = 0. dvdt(:,:) = 0. dqdt(:,:,1)= 0. - do iCol = 1,nCol - do iprc = 1,nPhysProcess + do iprc = 1,nPhysProcess + do iCol = 1,nCol + ! + dT = 0. + du = 0. + dv = 0. + dq = 0. ! Using scheme simulator if (physics_process(iprc)%use_sim) then @@ -728,18 +719,18 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (physics_process(iprc)%name == "cldMP") index_of_process = index_of_process_mp ! idtend = dtidx(index_of_temperature,index_of_process) - if (idtend >= 1) dT = dtend(iCol,:,idtend) + if (idtend >= 1) dT = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(index_of_x_wind,index_of_process) - if (idtend >= 1) du = dtend(iCol,:,idtend) + if (idtend >= 1) du = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(index_of_y_wind,index_of_process) - if (idtend >= 1) dv = dtend(iCol,:,idtend) + if (idtend >= 1) dv = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(100+ntqv,index_of_process) - if (idtend >= 1) dq = dtend(iCol,:,idtend) + if (idtend >= 1) dq = dtend(iCol,:,idtend)/dtp endif - + ! Update state now? if (physics_process(iprc)%time_split) then gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + dT)*dtp @@ -750,7 +741,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dudt(iCol,:) = 0. dvdt(iCol,:) = 0. dqdt(iCol,:,1) = 0. - ! Accumulate tendencies, update later? + ! Accumulate tendencies, update later? else dTdt(iCol,:) = dTdt(iCol,:) + dT dudt(iCol,:) = dudt(iCol,:) + du @@ -765,6 +756,13 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti gq0(iCol,:,1) = gq1(iCol,:,1) + dqdt(iCol,:,1)*dtp enddo ! + + do iCol=1,size(gq0(:,1,1)) + do iLay=1,size(gq0(1,:,1)) + write(*,'(i5,4f8.3)') iLay,tgrs(iCol,iLay),gt0(iCol,iLay),gt1(iCol,iLay),gt0(iCol,iLay)-gt1(iCol,iLay) + enddo + enddo + end subroutine ccpp_scheme_simulator_run ! #################################################################################### From 112ac895f62c3d4034dac67ec73b0d126b78098f Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 7 Feb 2023 12:36:11 -0700 Subject: [PATCH 07/64] Some small cleanup --- physics/ccpp_scheme_simulator.F90 | 103 +++++++++++------------------ physics/ccpp_scheme_simulator.meta | 7 -- 2 files changed, 39 insertions(+), 71 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index be7ad03f9..b3075e36a 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -116,15 +116,12 @@ module ccpp_scheme_simulator ! Data driven physics tendencies integer :: nlev_data, ntime_data real(kind_phys), allocatable, dimension(:) :: time_data - real(kind_phys), allocatable, dimension(:,:),target :: dTdt_LWRAD_data, dTdt_SWRAD_data, & - dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, dudt_GWD_data, & - dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, dTdt_DCNV_data, & - dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:,:),target :: dqdt_PBL_data, dqdt_SCNV_data, & - dqdt_DCNV_data, dqdt_cldMP_data - - ! Host-model initial time information - integer :: init_year, init_month, init_day, init_hour, init_min, init_sec + real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & + dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & + dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & + dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data + real(kind_phys), allocatable, dimension(:,:,:), target :: dqdt_PBL_data, & + dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data public ccpp_scheme_simulator_init, ccpp_scheme_simulator_run contains @@ -138,12 +135,11 @@ module ccpp_scheme_simulator !! \htmlinclude ccpp_scheme_simulator_init.html !! subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, & - idat, errmsg, errflg) + errmsg, errflg) ! Inputs integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit character(len=*), intent (in) :: nml_file - integer, intent (in), dimension(8) :: idat ! Outputs character(len=*), intent(out) :: errmsg @@ -168,14 +164,6 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil errmsg = '' errflg = 0 - ! Store model initialization time. - init_year = idat(1) - init_month = idat(2) - init_day = idat(3) - init_hour = idat(5) - init_min = idat(6) - init_sec = idat(7) - ! ###################################################################################### ! ! Read in namelist @@ -592,10 +580,12 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil print*, "---------------------------------" print*, " " do iprc = 1,nPhysProcess - print*,"Process : ", trim(physics_process(iprc)%name) - print*," order : ", physics_process(iprc)%order - print*," use_sim : ", physics_process(iprc)%use_sim - print*," time_split : ", physics_process(iprc)%time_split + if (physics_process(iprc)%use_sim) then + print*,"Process : ", trim(physics_process(iprc)%name) + print*," order : ", physics_process(iprc)%order + print*," use_sim : ", physics_process(iprc)%use_sim + print*," time_split : ", physics_process(iprc)%time_split + endif enddo print*, "---------------------------------" endif @@ -662,7 +652,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti nTrc = size(gq0(1,1,:)) ! Allocate temporaries - allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) ! *only specific humidity to start (ntrc=1). + allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) allocate(dT(nLay), du(nLay), dv(nLay), dq(nLay)) @@ -675,6 +665,8 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dudt(:,:) = 0. dvdt(:,:) = 0. dqdt(:,:,1)= 0. + + ! Model internal physics timestep evolution of "state". do iprc = 1,nPhysProcess do iCol = 1,nCol ! @@ -685,31 +677,21 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Using scheme simulator if (physics_process(iprc)%use_sim) then - print*,"Using CCPP scheme simulator for ",trim(physics_process(iprc)%name) - - ! Temperature if (associated(physics_process(iprc)%tend%T)) then - call interp_data_tend("T", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dT) + call linterp_data_tend("T", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dT) endif - - ! Zonal-wind if (associated(physics_process(iprc)%tend%u)) then - call interp_data_tend("u", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, du) + call linterp_data_tend("u", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, du) endif - - ! Meridional-wind if (associated(physics_process(iprc)%tend%v)) then - call interp_data_tend("v", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dv) + call linterp_data_tend("v", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dv) endif - - ! Specific-humidity if (associated(physics_process(iprc)%tend%q)) then - call interp_data_tend("q", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dq) + call linterp_data_tend("q", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dq) endif ! Using data tendency from "active" scheme(s). else - print*,"ACTIVE PHYSICS SCHEME: ",trim(physics_process(iprc)%name) if (physics_process(iprc)%name == "LWRAD") index_of_process = index_of_process_longwave if (physics_process(iprc)%name == "SWRAD") index_of_process = index_of_process_shortwave if (physics_process(iprc)%name == "PBL") index_of_process = index_of_process_pbl @@ -730,7 +712,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti idtend = dtidx(100+ntqv,index_of_process) if (idtend >= 1) dq = dtend(iCol,:,idtend)/dtp endif - + ! Update state now? if (physics_process(iprc)%time_split) then gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + dT)*dtp @@ -754,22 +736,17 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp gq0(iCol,:,1) = gq1(iCol,:,1) + dqdt(iCol,:,1)*dtp - enddo - ! - do iCol=1,size(gq0(:,1,1)) - do iLay=1,size(gq0(1,:,1)) - write(*,'(i5,4f8.3)') iLay,tgrs(iCol,iLay),gt0(iCol,iLay),gt1(iCol,iLay),gt0(iCol,iLay)-gt1(iCol,iLay) - enddo enddo - + ! end subroutine ccpp_scheme_simulator_run ! #################################################################################### ! Utility functions/routines ! #################################################################################### - subroutine interp_data_tend(var_name, process_name, iprc, year, month, day, hour, minute, & - second, var_out) + ! The routine interpolates the data-tendencies + subroutine linterp_data_tend(var_name, process_name, iprc, year, month, day, hour, & + minute, second, var_out) ! Inputs character(len=*), intent(in) :: var_name, process_name integer, intent(in) :: year, month, day, hour, minute, second, iprc @@ -781,6 +758,7 @@ subroutine interp_data_tend(var_name, process_name, iprc, year, month, day, hour integer :: ti(1), tf(1) real(kind_phys) :: w1, w2, hrofday + ! Linear interpolation weights hrofday = hour*3600. + minute*60. + second ti = findloc(abs(time_data-hrofday),minval(abs(time_data-hrofday))) if (hrofday - time_data(ti(1)) .le. 0) ti = ti-1 @@ -788,21 +766,18 @@ subroutine interp_data_tend(var_name, process_name, iprc, year, month, day, hour w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) w2 = 1 - w1 - if (var_name == "T") then - var_out = w1*physics_process(iprc)%tend%T(:,ti(1)) + w2*physics_process(iprc)%tend%T(:,tf(1)) - endif - - if (var_name == "u") then - var_out = w1*physics_process(iprc)%tend%u(:,ti(1)) + w2*physics_process(iprc)%tend%u(:,tf(1)) - endif - - if (var_name == "v") then - var_out = w1*physics_process(iprc)%tend%v(:,ti(1)) + w2*physics_process(iprc)%tend%v(:,tf(1)) - endif - - if (var_name == "q") then - var_out = w1*physics_process(iprc)%tend%q(:,ti(1),1) + w2*physics_process(iprc)%tend%q(:,tf(1),1) - endif - end subroutine interp_data_tend + ! + select case(var_name) + case("T") + var_out = w1*physics_process(iprc)%tend%T(:,ti(1)) + w2*physics_process(iprc)%tend%T(:,tf(1)) + case("u") + var_out = w1*physics_process(iprc)%tend%u(:,ti(1)) + w2*physics_process(iprc)%tend%u(:,tf(1)) + case("v") + var_out = w1*physics_process(iprc)%tend%v(:,ti(1)) + w2*physics_process(iprc)%tend%v(:,tf(1)) + case("q") + var_out = w1*physics_process(iprc)%tend%q(:,ti(1),1) + w2*physics_process(iprc)%tend%q(:,tf(1),1) + end select + + end subroutine linterp_data_tend end module ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 92e39ff61..80f898ed2 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -43,13 +43,6 @@ type = character kind = len=* intent = in -[idat] - standard_name = date_and_time_at_model_initialization_in_iso_order - long_name = initialization date and time - units = none - dimensions = (8) - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 7e2954615d03ee085c2cbc91d6326ee2ecac88cb Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Tue, 7 Feb 2023 15:12:09 -0700 Subject: [PATCH 08/64] update sfc_land --- physics/sfc_land.f | 39 +++++++++++++++++++++------------------ physics/sfc_land.meta | 16 ++++++++++++++++ 2 files changed, 37 insertions(+), 18 deletions(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index 0c3130bbe..ab0691251 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -36,9 +36,10 @@ subroutine sfc_land_run & ! --- inputs: & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & - & ep_lnd, t2mmp_lnd, q2mp_lnd, & + & ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & ! --- outputs: & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & + & gflux, & & errmsg, errflg, naux2d, aux2d & ) @@ -52,9 +53,10 @@ subroutine sfc_land_run & ! inputs: ! ! ( im, cpllnd, cpllnd2atm, flag_iter, dry, ! ! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! -! ep_lnd, t2mmp_lnd, q2mp_lnd, ! +! ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, ! ! outputs: ! ! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! +! gflux, ! ! errmsg, errflg) ! ! ! ! ==================== defination of variables ==================== ! @@ -71,7 +73,8 @@ subroutine sfc_land_run & ! hflx_lnd - real , sensible heat ! ep_lnd - real , surface upward potential latent heat flux ! t2mmp_lnd - real , 2m temperature -! q2mp_lnd - real , 2m specific humidity +! q2mp_lnd - real , 2m specific humidity +! gflux_lnd - real , soil heat flux over land ! outputs: ! sncovr1 - real , snow cover over land ! qsurf - real , specific humidity at sfc @@ -79,7 +82,8 @@ subroutine sfc_land_run & ! hflx - real , sensible heat ! ep - real , potential evaporation ! t2mmp - real , temperature at 2m -! q2mp - real , specific humidity at 2m +! q2mp - real , specific humidity at 2m +! gflux - real , soil heat flux over land ! ==================== end of description ===================== ! ! ! @@ -94,11 +98,11 @@ subroutine sfc_land_run & real (kind=kind_phys), dimension(:), intent(in) :: & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & - & t2mmp_lnd, q2mp_lnd + & t2mmp_lnd, q2mp_lnd, gflux_lnd ! --- outputs: real (kind=kind_phys), dimension(:), intent(out) :: & - & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp + & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -117,25 +121,24 @@ subroutine sfc_land_run & if (.not. cpllnd2atm) return ! do i = 1, im - !if (flag_iter(i) .and. dry(i)) then - !if (dry(i)) then - sncovr1(i) = sncovr1_lnd(i) - qsurf(i) = qsurf_lnd(i) - hflx(i) = hflx_lnd(i) - evap(i) = evap_lnd(i) - ep(i) = ep_lnd(i) - t2mmp(i) = t2mmp_lnd(i) - q2mp(i) = q2mp_lnd(i) - !end if + sncovr1(i) = sncovr1_lnd(i) + qsurf(i) = qsurf_lnd(i) + hflx(i) = hflx_lnd(i) + evap(i) = evap_lnd(i) + ep(i) = ep_lnd(i) + t2mmp(i) = t2mmp_lnd(i) + q2mp(i) = q2mp_lnd(i) + gflux(i) = gflux_lnd(i) enddo - aux2d(:,1) = dry(:) !sncovr1(:) + aux2d(:,1) = sncovr1(:) aux2d(:,2) = qsurf(:) aux2d(:,3) = hflx(:) aux2d(:,4) = evap(:) aux2d(:,5) = ep(:) - aux2d(:,6) = qsurf_lnd(:) !t2mmp(:) + aux2d(:,6) = t2mmp(:) aux2d(:,7) = q2mp(:) + aux2d(:,8) = gflux(:) return !----------------------------------- diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index f31d779ae..50ddecd46 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -98,6 +98,14 @@ type = real kind = kind_phys intent = in +[gflux_lnd] + standard_name = upward_heat_flux_in_soil_over_land_from_land + long_name = soil heat flux over land for coupling + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [sncovr1] standard_name = surface_snow_area_fraction_over_land long_name = surface snow area fraction @@ -154,6 +162,14 @@ type = real kind = kind_phys intent = out +[gflux] + standard_name = upward_heat_flux_in_soil_over_land + long_name = soil heat flux over land + units = W m-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6a4c4b17c94130955de38b5dff5fc7e284d77dce Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 9 Feb 2023 15:04:23 -0700 Subject: [PATCH 09/64] More OO changes. Will split into load_data and ccpp_scheme components soon. --- physics/ccpp_scheme_simulator.F90 | 274 ++++++++++++++++-------------- 1 file changed, 143 insertions(+), 131 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index b3075e36a..3c82fe094 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -13,10 +13,6 @@ module ccpp_scheme_simulator #endif implicit none - ! Avaialble physics processes to simulate. - integer,parameter :: & - nPhysProcess = 7 - ! Type containing physics tendencies for a physics process. type phys_tend real(kind_phys), dimension(:,:), pointer :: T @@ -28,16 +24,18 @@ module ccpp_scheme_simulator ! This type contains the meta information and data for each physics process. type base_physics_process character(len=16) :: name - logical :: time_split - logical :: use_sim + logical :: time_split = .false. + logical :: use_sim = .false. integer :: order type(phys_tend) :: tend end type base_physics_process ! This array contains the governing information on how to advance the physics timestep. - type(base_physics_process),dimension(nPhysProcess) :: & + type(base_physics_process),dimension(:), allocatable :: & physics_process + integer :: nPhysProcess + ! ######################################################################################## ! ! Configuration for CCPP scheme simulator. Set in namelist. Used during initialization to @@ -45,74 +43,20 @@ module ccpp_scheme_simulator ! ! ######################################################################################## - ! Set which schemes to be replaced with simulated tendencies. - logical :: use_LWRAD_scheme_sim = .false., & !< If true, use LongWave RADiation scheme simulator. - !< If false, use tendencies from radiation scheme. - use_SWRAD_scheme_sim = .false., & !< If true, use ShortWave RADiation scheme simulator. - !< If false, use tendencies from radiation scheme. - use_PBL_scheme_sim = .false., & !< If true, use Planetary Boubdary Layer scheme simulator. - !< If false, use tendencies from PBL scheme. - use_GWD_scheme_sim = .false., & !< If true, use Gravity Wave Drag scheme simulator. - !< If false, use tendencies from GWD scheme. - use_SCNV_scheme_sim = .false., & !< If true, use Shallow CoNVection scheme simulator. - !< If false, use tendencies from SCNV scheme. - use_DCNV_scheme_sim = .false., & !< If true, use Deep CoNVection scheme simulator. - !< If false, use tendencies from DCNV scheme. - use_cldMP_scheme_sim = .false. !< If true, use cloud MicroPhysics scheme simulator. - !< If false, use tendencies from cldMP acheme. - - ! Are the processes time-split or process-split? - logical :: time_split_LWRAD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_SWRAD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_PBL = .false., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_GWD = .false., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_SCNV = .true., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_DCNV = .true., & !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - time_split_cldMP = .true. !< If true, time-split process. Update internal physics state prior to scheme. - !< If false, process-split process. Accumulate tendencies. - - ! What is physics process ordering? (Important if their are time-split processes in the physics scheme) - integer :: scheme_order_SWRAD = 1, & !< Order of Radiation scheme (shortwave). - scheme_order_LWRAD = 2, & !< Order of Radiation scheme (longwave). - scheme_order_PBL = 3, & !< Order of Planetary Boubdary Layer scheme. - scheme_order_GWD = 4, & !< Order of Gravity Wave Drag scheme. - scheme_order_SCNV = 5, & !< Order of Shallow CoNVection scheme. - scheme_order_DCNV = 6, & !< Order of Deep CoNVection scheme. - scheme_order_cldMP = 7 !< Order of cloud MicroPhysics scheme. - ! - ! Locals - ! + ! For each process there is a corresponding namelist entry, which is constructed as follows: + ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} + integer, dimension(3) :: & + proc_LWRAD_config = (/0,0,0/), & + proc_SWRAD_config = (/0,0,0/), & + proc_PBL_config = (/0,0,0/), & + proc_GWD_config = (/0,0,0/), & + proc_SCNV_config = (/0,0,0/), & + proc_DCNV_config = (/0,0,0/), & + proc_cldMP_config = (/0,0,0/) ! Activation flag for scheme. logical :: do_ccpp_scheme_simulator = .false. - ! Switches for input data - logical :: have_dTdt_LWRAD_data = .false., & !< If true, input file contains LongWave RADiation temperature tendencies. - have_dTdt_SWRAD_data = .false., & !< If true, input file contains ShortWave RADiation temperature tendencies. - have_dTdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer temperature tendencies. - have_dqdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer specific-humidity tendencies. - have_dudt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer zonal-wind tendencies. - have_dvdt_PBL_data = .false., & !< If true, input file contains Planetary Boubdary Layer meridional-wind tendencies. - have_dTdt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag temperature tendencies. - have_dudt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag zonal-wind tendencies. - have_dvdt_GWD_data = .false., & !< If true, input file contains Gravity Wave Drag meridional-wind tendencies. - have_dTdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection temperature tendencies. - have_dudt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection zonal-wind tendencies. - have_dvdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection meridional-wind tendencies. - have_dqdt_SCNV_data = .false., & !< If true, input file contains Shallow CoNVection specific-humidity tendencies. - have_dTdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection temperature tendencies. - have_dudt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection zonal-wind tendencies. - have_dvdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection meridional-wind tendencies. - have_dqdt_DCNV_data = .false., & !< If true, input file contains Deep CoNVection specific-humidity tendencies. - have_dTdt_cldMP_data = .false., & !< If true, input file contains cloud MicroPhysics temperature tendencies. - have_dqdt_cldMP_data = .false. !< If true, input file contains cloud MicroPhysics specific-humidity tendencies. - ! Data driven physics tendencies integer :: nlev_data, ntime_data real(kind_phys), allocatable, dimension(:) :: time_data @@ -123,6 +67,12 @@ module ccpp_scheme_simulator real(kind_phys), allocatable, dimension(:,:,:), target :: dqdt_PBL_data, & dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data + ! Scheme initialization flag. + logical :: module_initialized = .false. + + ! Order in process loop for "active" physics process. + integer :: iactive_scheme + public ccpp_scheme_simulator_init, ccpp_scheme_simulator_run contains @@ -151,19 +101,39 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil logical :: exists integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality + ! Switches for input data + logical :: have_dTdt_LWRAD_data = .false., & + have_dTdt_SWRAD_data = .false., & + have_dTdt_PBL_data = .false., & + have_dqdt_PBL_data = .false., & + have_dudt_PBL_data = .false., & + have_dvdt_PBL_data = .false., & + have_dTdt_GWD_data = .false., & + have_dudt_GWD_data = .false., & + have_dvdt_GWD_data = .false., & + have_dTdt_SCNV_data = .false., & + have_dudt_SCNV_data = .false., & + have_dvdt_SCNV_data = .false., & + have_dqdt_SCNV_data = .false., & + have_dTdt_DCNV_data = .false., & + have_dudt_DCNV_data = .false., & + have_dvdt_DCNV_data = .false., & + have_dqdt_DCNV_data = .false., & + have_dTdt_cldMP_data = .false., & + have_dqdt_cldMP_data = .false. + ! Namelist - namelist / scm_data_nml / fileIN, & - use_SWRAD_scheme_sim, use_LWRAD_scheme_sim, use_PBL_scheme_sim, & - use_GWD_scheme_sim, use_SCNV_scheme_sim, use_DCNV_scheme_sim, & - use_cldMP_scheme_sim, scheme_order_SWRAD, scheme_order_LWRAD, scheme_order_PBL, & - scheme_order_GWD, scheme_order_SCNV, scheme_order_DCNV, scheme_order_cldMP, & - time_split_SWRAD, time_split_LWRAD, time_split_PBL, time_split_GWD, & - time_split_SCNV, time_split_DCNV, time_split_cldMP + namelist / scm_data_nml / fileIN, nPhysProcess, proc_LWRAD_config, proc_SWRAD_config, & + proc_PBL_config, proc_GWD_config, proc_SCNV_config, proc_DCNV_config, & + proc_cldMP_config ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + if (module_initialized) return + module_initialized = .true. + ! ###################################################################################### ! ! Read in namelist @@ -187,9 +157,9 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil ! ! ###################################################################################### ! Only proceed if scheme simulator requested. - if (use_SWRAD_scheme_sim .or. use_LWRAD_scheme_sim .or. use_PBL_scheme_sim .or. & - use_GWD_scheme_sim .or. use_SCNV_scheme_sim .or. use_DCNV_scheme_sim .or. & - use_cldMP_scheme_sim) then + if (proc_SWRAD_config(1) .or. proc_LWRAD_config(1) .or. proc_PBL_config(1) .or. & + proc_GWD_config(1) .or. proc_SCNV_config(1) .or. proc_DCNV_config(1) .or. & + proc_cldMP_config(1)) then do_ccpp_scheme_simulator = .true. else return @@ -507,87 +477,128 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil ! ! ####################################################################################### + ! Allocate + allocate(physics_process(nPhysProcess)) + ! Metadata do iprc = 1,nPhysProcess - if (iprc == scheme_order_SWRAD) then + if (iprc == proc_SWRAD_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "SWRAD" - physics_process(iprc)%use_sim = use_SWRAD_scheme_sim - physics_process(iprc)%time_split = time_split_SWRAD + if (proc_SWRAD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_SWRAD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_LWRAD) then + if (iprc == proc_LWRAD_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "LWRAD" - physics_process(iprc)%use_sim = use_LWRAD_scheme_sim - physics_process(iprc)%time_split = time_split_LWRAD + if (proc_LWRAD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_LWRAD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_GWD) then + if (iprc == proc_GWD_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "GWD" - physics_process(iprc)%use_sim = use_GWD_scheme_sim - physics_process(iprc)%time_split = time_split_GWD + if (proc_GWD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_GWD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_PBL) then + if (iprc == proc_PBL_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "PBL" - physics_process(iprc)%use_sim = use_PBL_scheme_sim - physics_process(iprc)%time_split = time_split_PBL + if (proc_PBL_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_PBL_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_SCNV) then + if (iprc == proc_SCNV_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "SCNV" - physics_process(iprc)%use_sim = use_SCNV_scheme_sim - physics_process(iprc)%time_split = time_split_SCNV + if (proc_SCNV_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_SCNV_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_DCNV) then + if (iprc == proc_DCNV_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "DCNV" - physics_process(iprc)%use_sim = use_DCNV_scheme_sim - physics_process(iprc)%time_split = time_split_DCNV + if (proc_DCNV_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_DCNV_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif - if (iprc == scheme_order_cldMP) then + if (iprc == proc_cldMP_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "cldMP" - physics_process(iprc)%use_sim = use_cldMP_scheme_sim - physics_process(iprc)%time_split = time_split_cldMP + if (proc_cldMP_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_cldMP_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif endif enddo - ! Data - if (have_dTdt_LWRAD_data) physics_process(scheme_order_LWRAD)%tend%T => dTdt_LWRAD_data - if (have_dTdt_SWRAD_data) physics_process(scheme_order_SWRAD)%tend%T => dTdt_SWRAD_data - if (have_dTdt_PBL_data) physics_process(scheme_order_PBL)%tend%T => dTdt_PBL_data - if (have_dudt_PBL_data) physics_process(scheme_order_PBL)%tend%u => dudt_PBL_data - if (have_dvdt_PBL_data) physics_process(scheme_order_PBL)%tend%v => dvdt_PBL_data - if (have_dqdt_PBL_data) physics_process(scheme_order_PBL)%tend%q => dqdt_PBL_data - if (have_dTdt_GWD_data) physics_process(scheme_order_GWD)%tend%T => dTdt_GWD_data - if (have_dudt_GWD_data) physics_process(scheme_order_GWD)%tend%u => dudt_GWD_data - if (have_dvdt_GWD_data) physics_process(scheme_order_GWD)%tend%v => dvdt_GWD_data - if (have_dTdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%T => dTdt_SCNV_data - if (have_dudt_SCNV_data) physics_process(scheme_order_SCNV)%tend%u => dudt_SCNV_data - if (have_dvdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%v => dvdt_SCNV_data - if (have_dqdt_SCNV_data) physics_process(scheme_order_SCNV)%tend%q => dqdt_SCNV_data - if (have_dTdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%T => dTdt_DCNV_data - if (have_dudt_DCNV_data) physics_process(scheme_order_DCNV)%tend%u => dudt_DCNV_data - if (have_dvdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%v => dvdt_DCNV_data - if (have_dqdt_DCNV_data) physics_process(scheme_order_DCNV)%tend%q => dqdt_DCNV_data - if (have_dTdt_cldMP_data) physics_process(scheme_order_cldMP)%tend%T => dTdt_cldMP_data - if (have_dqdt_cldMP_data) physics_process(scheme_order_cldMP)%tend%q => dqdt_cldMP_data + ! Load data + if (have_dTdt_LWRAD_data) physics_process(proc_SWRAD_config(3))%tend%T => dTdt_LWRAD_data + if (have_dTdt_SWRAD_data) physics_process(proc_LWRAD_config(3))%tend%T => dTdt_SWRAD_data + if (have_dTdt_PBL_data) physics_process(proc_PBL_config(3))%tend%T => dTdt_PBL_data + if (have_dudt_PBL_data) physics_process(proc_PBL_config(3))%tend%u => dudt_PBL_data + if (have_dvdt_PBL_data) physics_process(proc_PBL_config(3))%tend%v => dvdt_PBL_data + if (have_dqdt_PBL_data) physics_process(proc_PBL_config(3))%tend%q => dqdt_PBL_data + if (have_dTdt_GWD_data) physics_process(proc_GWD_config(3))%tend%T => dTdt_GWD_data + if (have_dudt_GWD_data) physics_process(proc_GWD_config(3))%tend%u => dudt_GWD_data + if (have_dvdt_GWD_data) physics_process(proc_GWD_config(3))%tend%v => dvdt_GWD_data + if (have_dTdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%T => dTdt_SCNV_data + if (have_dudt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%u => dudt_SCNV_data + if (have_dvdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%v => dvdt_SCNV_data + if (have_dqdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%q => dqdt_SCNV_data + if (have_dTdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%T => dTdt_DCNV_data + if (have_dudt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%u => dudt_DCNV_data + if (have_dvdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%v => dvdt_DCNV_data + if (have_dqdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%q => dqdt_DCNV_data + if (have_dTdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend%T => dTdt_cldMP_data + if (have_dqdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend%q => dqdt_cldMP_data + + ! Which process-scheme is "Active"? + do iprc = 1,nPhysProcess + if (.not. physics_process(iprc)%use_sim) then + iactive_scheme = iprc + endif + enddo ! if (mpirank .eq. mpiroot) then + print*, "----------------------------------" print*, "--- Using CCPP data tendencies ---" - print*, "---------------------------------" - print*, " " + print*, "----------------------------------" do iprc = 1,nPhysProcess if (physics_process(iprc)%use_sim) then - print*,"Process : ", trim(physics_process(iprc)%name) - print*," order : ", physics_process(iprc)%order - print*," use_sim : ", physics_process(iprc)%use_sim - print*," time_split : ", physics_process(iprc)%time_split + print*," simulate_scheme: ", trim(physics_process(iprc)%name) + print*," order: ", physics_process(iprc)%order + print*," time_split: ", physics_process(iprc)%time_split endif enddo - print*, "---------------------------------" + print*, " active_scheme: ", trim(physics_process(iactive_scheme)%name) + print*, " order: ", physics_process(iactive_scheme)%order + print*, " time_split : ", physics_process(iactive_scheme)%time_split + print*, "----------------------------------" + print*, "----------------------------------" endif end subroutine ccpp_scheme_simulator_init @@ -675,7 +686,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dv = 0. dq = 0. - ! Using scheme simulator + ! Using scheme simulator (very simple, interpolate data tendency to local time) if (physics_process(iprc)%use_sim) then if (associated(physics_process(iprc)%tend%T)) then call linterp_data_tend("T", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dT) @@ -691,6 +702,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti endif ! Using data tendency from "active" scheme(s). + ! DJS2023: This block is very ufs specific. Need to tidy this up. else if (physics_process(iprc)%name == "LWRAD") index_of_process = index_of_process_longwave if (physics_process(iprc)%name == "SWRAD") index_of_process = index_of_process_shortwave @@ -745,7 +757,7 @@ end subroutine ccpp_scheme_simulator_run ! Utility functions/routines ! #################################################################################### ! The routine interpolates the data-tendencies - subroutine linterp_data_tend(var_name, process_name, iprc, year, month, day, hour, & + subroutine linterp_data_tend(var_name, process_name, iprc, year, month, day, hour, & minute, second, var_out) ! Inputs character(len=*), intent(in) :: var_name, process_name From be4cc2e5acb11c99794d465496503833a4842a45 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 9 Feb 2023 19:25:45 -0700 Subject: [PATCH 10/64] More OO changes --- physics/ccpp_scheme_simulator.F90 | 134 +++++++++++++++++------------- 1 file changed, 75 insertions(+), 59 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 3c82fe094..f8f040be2 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -13,27 +13,41 @@ module ccpp_scheme_simulator #endif implicit none - ! Type containing physics tendencies for a physics process. - type phys_tend + ! Type containing 1D (instantaneous) physics tendencies + type tend_inst + real(kind_phys), dimension(:), pointer :: dT + real(kind_phys), dimension(:), pointer :: du + real(kind_phys), dimension(:), pointer :: dv + real(kind_phys), dimension(:), pointer :: dq + end type tend_inst + + ! Type containing 2D data physics tendencies. + type phys_tend_2d + real(kind_phys), dimension(:), pointer :: time real(kind_phys), dimension(:,:), pointer :: T real(kind_phys), dimension(:,:), pointer :: u real(kind_phys), dimension(:,:), pointer :: v real(kind_phys), dimension(:,:,:), pointer :: q - end type phys_tend + end type phys_tend_2d ! This type contains the meta information and data for each physics process. type base_physics_process - character(len=16) :: name - logical :: time_split = .false. - logical :: use_sim = .false. - integer :: order - type(phys_tend) :: tend + character(len=16) :: name + logical :: time_split = .false. + logical :: use_sim = .false. + integer :: order + type(phys_tend_2d) :: tend + type(tend_inst) :: itend + contains + generic, public :: linterp => linterp_1D + procedure, private :: linterp_1D end type base_physics_process ! This array contains the governing information on how to advance the physics timestep. type(base_physics_process),dimension(:), allocatable :: & physics_process + ! Number of physics process (set in namelist) integer :: nPhysProcess ! ######################################################################################## @@ -59,7 +73,7 @@ module ccpp_scheme_simulator ! Data driven physics tendencies integer :: nlev_data, ntime_data - real(kind_phys), allocatable, dimension(:) :: time_data + real(kind_phys), allocatable, dimension(:), target :: time_data real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & @@ -482,6 +496,10 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil ! Metadata do iprc = 1,nPhysProcess + allocate(physics_process(iprc)%itend%dT(nlev_data)) + allocate(physics_process(iprc)%itend%du(nlev_data)) + allocate(physics_process(iprc)%itend%dv(nlev_data)) + allocate(physics_process(iprc)%itend%dq(nlev_data)) if (iprc == proc_SWRAD_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "SWRAD" @@ -555,6 +573,13 @@ subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_fil enddo ! Load data + physics_process(proc_LWRAD_config(3))%tend%time => time_data + physics_process(proc_SWRAD_config(3))%tend%time => time_data + physics_process(proc_PBL_config(3))%tend%time => time_data + physics_process(proc_GWD_config(3))%tend%time => time_data + physics_process(proc_DCNV_config(3))%tend%time => time_data + physics_process(proc_SCNV_config(3))%tend%time => time_data + physics_process(proc_cldMP_config(3))%tend%time => time_data if (have_dTdt_LWRAD_data) physics_process(proc_SWRAD_config(3))%tend%T => dTdt_LWRAD_data if (have_dTdt_SWRAD_data) physics_process(proc_LWRAD_config(3))%tend%T => dTdt_SWRAD_data if (have_dTdt_PBL_data) physics_process(proc_PBL_config(3))%tend%T => dTdt_PBL_data @@ -639,7 +664,6 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti integer :: iCol, iLay, iTrc, nCol, nLay, nTrc, ti(1), tf(1), idtend, fcst_year, & fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, iprc, index_of_process real(kind_phys) :: w1, w2,hrofday - real(kind_phys), dimension(:), allocatable :: dT, du, dv, dq real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt real(kind_phys), dimension(:,:,:), allocatable :: gq1, dqdt @@ -649,7 +673,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (.not. do_ccpp_scheme_simulator) return - ! Current forecast time + ! Current forecast time (Data-format specific) fcst_year = jdat(1) fcst_month = jdat(2) fcst_day = jdat(3) @@ -665,7 +689,6 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Allocate temporaries allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) - allocate(dT(nLay), du(nLay), dv(nLay), dq(nLay)) ! Set state gt1(:,:) = tgrs(:,:) @@ -680,25 +703,25 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Model internal physics timestep evolution of "state". do iprc = 1,nPhysProcess do iCol = 1,nCol - ! - dT = 0. - du = 0. - dv = 0. - dq = 0. + ! Reset locals + physics_process(iprc)%itend%dT(:) = 0. + physics_process(iprc)%itend%du(:) = 0. + physics_process(iprc)%itend%dv(:) = 0. + physics_process(iprc)%itend%dq(:) = 0. ! Using scheme simulator (very simple, interpolate data tendency to local time) if (physics_process(iprc)%use_sim) then if (associated(physics_process(iprc)%tend%T)) then - call linterp_data_tend("T", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dT) + errmsg = physics_process(iprc)%linterp("T", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif if (associated(physics_process(iprc)%tend%u)) then - call linterp_data_tend("u", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, du) + errmsg = physics_process(iprc)%linterp("u", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif if (associated(physics_process(iprc)%tend%v)) then - call linterp_data_tend("v", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dv) + errmsg = physics_process(iprc)%linterp("v", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif if (associated(physics_process(iprc)%tend%q)) then - call linterp_data_tend("q", physics_process(iprc)%name, iprc, fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, dq) + errmsg = physics_process(iprc)%linterp("q", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif ! Using data tendency from "active" scheme(s). @@ -713,34 +736,34 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (physics_process(iprc)%name == "cldMP") index_of_process = index_of_process_mp ! idtend = dtidx(index_of_temperature,index_of_process) - if (idtend >= 1) dT = dtend(iCol,:,idtend)/dtp + if (idtend >= 1) physics_process(iprc)%itend%dT = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(index_of_x_wind,index_of_process) - if (idtend >= 1) du = dtend(iCol,:,idtend)/dtp + if (idtend >= 1) physics_process(iprc)%itend%du = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(index_of_y_wind,index_of_process) - if (idtend >= 1) dv = dtend(iCol,:,idtend)/dtp + if (idtend >= 1) physics_process(iprc)%itend%dv = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(100+ntqv,index_of_process) - if (idtend >= 1) dq = dtend(iCol,:,idtend)/dtp + if (idtend >= 1) physics_process(iprc)%itend%dq = dtend(iCol,:,idtend)/dtp endif ! Update state now? if (physics_process(iprc)%time_split) then - gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + dT)*dtp - gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + du)*dtp - gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + dv)*dtp - gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + dq)*dtp + gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%itend%dT)*dtp + gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%itend%du)*dtp + gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%itend%dv)*dtp + gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + physics_process(iprc)%itend%dq)*dtp dTdt(iCol,:) = 0. dudt(iCol,:) = 0. dvdt(iCol,:) = 0. dqdt(iCol,:,1) = 0. ! Accumulate tendencies, update later? else - dTdt(iCol,:) = dTdt(iCol,:) + dT - dudt(iCol,:) = dudt(iCol,:) + du - dvdt(iCol,:) = dvdt(iCol,:) + dv - dqdt(iCol,:,1) = dqdt(iCol,:,1) + dq + dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%itend%dT + dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%itend%du + dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%itend%dv + dqdt(iCol,:,1) = dqdt(iCol,:,1) + physics_process(iprc)%itend%dq endif enddo ! @@ -756,40 +779,33 @@ end subroutine ccpp_scheme_simulator_run ! #################################################################################### ! Utility functions/routines ! #################################################################################### - ! The routine interpolates the data-tendencies - subroutine linterp_data_tend(var_name, process_name, iprc, year, month, day, hour, & - minute, second, var_out) - ! Inputs - character(len=*), intent(in) :: var_name, process_name - integer, intent(in) :: year, month, day, hour, minute, second, iprc - - ! Outputs - real(kind_phys),dimension(:),intent(out) :: var_out - - ! Locals + function linterp_1D(this, var_name, year, month, day, hour, minute, second) result(err_message) + class(base_physics_process), intent(inout) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: year, month, day, hour, minute, second + character(len=128) :: err_message integer :: ti(1), tf(1) real(kind_phys) :: w1, w2, hrofday - ! Linear interpolation weights + ! Interpolation weights hrofday = hour*3600. + minute*60. + second - ti = findloc(abs(time_data-hrofday),minval(abs(time_data-hrofday))) - if (hrofday - time_data(ti(1)) .le. 0) ti = ti-1 + ti = findloc(abs(this%tend%time-hrofday),minval(abs(this%tend%time-hrofday))) + if (hrofday - this%tend%time(ti(1)) .le. 0) ti = ti-1 tf = ti + 1 - w1 = (time_data(tf(1))-hrofday) / (time_data(tf(1)) - time_data(ti(1))) + w1 = (this%tend%time(tf(1))-hrofday) / (this%tend%time(tf(1)) - this%tend%time(ti(1))) w2 = 1 - w1 - ! select case(var_name) - case("T") - var_out = w1*physics_process(iprc)%tend%T(:,ti(1)) + w2*physics_process(iprc)%tend%T(:,tf(1)) - case("u") - var_out = w1*physics_process(iprc)%tend%u(:,ti(1)) + w2*physics_process(iprc)%tend%u(:,tf(1)) - case("v") - var_out = w1*physics_process(iprc)%tend%v(:,ti(1)) + w2*physics_process(iprc)%tend%v(:,tf(1)) - case("q") - var_out = w1*physics_process(iprc)%tend%q(:,ti(1),1) + w2*physics_process(iprc)%tend%q(:,tf(1),1) + case("T") + this%itend%dT = w1*this%tend%T(:,ti(1)) + w2*this%tend%T(:,tf(1)) + case("u") + this%itend%du = w1*this%tend%u(:,ti(1)) + w2*this%tend%u(:,tf(1)) + case("v") + this%itend%dv = w1*this%tend%v(:,ti(1)) + w2*this%tend%v(:,tf(1)) + case("q") + this%itend%dq = w1*this%tend%q(:,ti(1),1) + w2*this%tend%q(:,tf(1),1) end select - end subroutine linterp_data_tend - + end function linterp_1D + end module ccpp_scheme_simulator From 7001ef9134859977e1c92c2d1b4f54a1c697183c Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 13 Feb 2023 09:50:59 -0700 Subject: [PATCH 11/64] Split scheme into load and simulator components. --- physics/ccpp_scheme_simulator.F90 | 837 +++++++---------------------- physics/ccpp_scheme_simulator.meta | 56 -- physics/load_ccpp_scheme_sim.F90 | 577 ++++++++++++++++++++ physics/load_ccpp_scheme_sim.meta | 60 +++ 4 files changed, 830 insertions(+), 700 deletions(-) create mode 100644 physics/load_ccpp_scheme_sim.F90 create mode 100644 physics/load_ccpp_scheme_sim.meta diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index f8f040be2..3b478844f 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -7,21 +7,21 @@ ! ######################################################################################## module ccpp_scheme_simulator use machine, only: kind_phys - use netcdf -#ifdef MPI - use mpi -#endif - implicit none - ! Type containing 1D (instantaneous) physics tendencies - type tend_inst - real(kind_phys), dimension(:), pointer :: dT - real(kind_phys), dimension(:), pointer :: du - real(kind_phys), dimension(:), pointer :: dv - real(kind_phys), dimension(:), pointer :: dq - end type tend_inst + implicit none - ! Type containing 2D data physics tendencies. + ! ######################################################################################## + ! Types used by the scheme simulator + ! ######################################################################################## + ! Type containing 1D (time) physics tendencies. + type phys_tend_1d + real(kind_phys), dimension(:), pointer :: T + real(kind_phys), dimension(:), pointer :: u + real(kind_phys), dimension(:), pointer :: v + real(kind_phys), dimension(:,:), pointer :: q + end type phys_tend_1d + + ! Type containing 2D (lev,time) physics tendencies. type phys_tend_2d real(kind_phys), dimension(:), pointer :: time real(kind_phys), dimension(:,:), pointer :: T @@ -30,603 +30,65 @@ module ccpp_scheme_simulator real(kind_phys), dimension(:,:,:), pointer :: q end type phys_tend_2d + ! Type containing 3D (loc,lev,time) physics tendencies. + type phys_tend_3d + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:), pointer :: lon + real(kind_phys), dimension(:), pointer :: lat + real(kind_phys), dimension(:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:,:), pointer :: q + end type phys_tend_3d + + ! Type containing 4D (lon, lat,lev,time) physics tendencies. + type phys_tend_4d + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:,:), pointer :: lon + real(kind_phys), dimension(:,:), pointer :: lat + real(kind_phys), dimension(:,:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:,:,:), pointer :: q + end type phys_tend_4d + ! This type contains the meta information and data for each physics process. type base_physics_process character(len=16) :: name logical :: time_split = .false. logical :: use_sim = .false. integer :: order - type(phys_tend_2d) :: tend - type(tend_inst) :: itend + type(phys_tend_1d) :: tend1d + type(phys_tend_2d) :: tend2d + type(phys_tend_3d) :: tend3d + type(phys_tend_4d) :: tend4d contains - generic, public :: linterp => linterp_1D + generic, public :: linterp => linterp_1D, linterp_2D procedure, private :: linterp_1D + procedure, private :: linterp_2D + procedure, public :: find_nearest_loc_2d_1d + procedure, public :: cmp_time_wts end type base_physics_process ! This array contains the governing information on how to advance the physics timestep. - type(base_physics_process),dimension(:), allocatable :: & + type(base_physics_process), dimension(:), allocatable :: & physics_process - ! Number of physics process (set in namelist) - integer :: nPhysProcess - - ! ######################################################################################## - ! - ! Configuration for CCPP scheme simulator. Set in namelist. Used during initialization to - ! populate "physics_processes" type array. - ! - ! ######################################################################################## - - ! For each process there is a corresponding namelist entry, which is constructed as follows: - ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} - integer, dimension(3) :: & - proc_LWRAD_config = (/0,0,0/), & - proc_SWRAD_config = (/0,0,0/), & - proc_PBL_config = (/0,0,0/), & - proc_GWD_config = (/0,0,0/), & - proc_SCNV_config = (/0,0,0/), & - proc_DCNV_config = (/0,0,0/), & - proc_cldMP_config = (/0,0,0/) - - ! Activation flag for scheme. - logical :: do_ccpp_scheme_simulator = .false. - - ! Data driven physics tendencies - integer :: nlev_data, ntime_data - real(kind_phys), allocatable, dimension(:), target :: time_data - real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & - dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & - dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & - dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:,:), target :: dqdt_PBL_data, & - dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data - - ! Scheme initialization flag. - logical :: module_initialized = .false. - - ! Order in process loop for "active" physics process. + ! For time-split physics process we need to call this scheme twice in the SDF, once + ! before the "active" scheme is called, and once after. This is because the active + ! scheme uses an internal physics state that has been advanced forward by a subsequent + ! physics process(es). + character(len=16) :: active_name integer :: iactive_scheme + integer :: proc_start, proc_end + logical :: active_time_split_process=.false. - public ccpp_scheme_simulator_init, ccpp_scheme_simulator_run -contains - - ! ###################################################################################### - ! - ! SUBROUTINE ccpp_scheme_simulator_init - ! - ! ###################################################################################### -!! \section arg_table_ccpp_scheme_simulator_init -!! \htmlinclude ccpp_scheme_simulator_init.html -!! - subroutine ccpp_scheme_simulator_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, & - errmsg, errflg) - - ! Inputs - integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit - character(len=*), intent (in) :: nml_file - - ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc - character(len=256) :: fileIN - logical :: exists - integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality - - ! Switches for input data - logical :: have_dTdt_LWRAD_data = .false., & - have_dTdt_SWRAD_data = .false., & - have_dTdt_PBL_data = .false., & - have_dqdt_PBL_data = .false., & - have_dudt_PBL_data = .false., & - have_dvdt_PBL_data = .false., & - have_dTdt_GWD_data = .false., & - have_dudt_GWD_data = .false., & - have_dvdt_GWD_data = .false., & - have_dTdt_SCNV_data = .false., & - have_dudt_SCNV_data = .false., & - have_dvdt_SCNV_data = .false., & - have_dqdt_SCNV_data = .false., & - have_dTdt_DCNV_data = .false., & - have_dudt_DCNV_data = .false., & - have_dvdt_DCNV_data = .false., & - have_dqdt_DCNV_data = .false., & - have_dTdt_cldMP_data = .false., & - have_dqdt_cldMP_data = .false. - - ! Namelist - namelist / scm_data_nml / fileIN, nPhysProcess, proc_LWRAD_config, proc_SWRAD_config, & - proc_PBL_config, proc_GWD_config, proc_SCNV_config, proc_DCNV_config, & - proc_cldMP_config - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (module_initialized) return - module_initialized = .true. - - ! ###################################################################################### - ! - ! Read in namelist - ! - ! ###################################################################################### - inquire (file = trim (nml_file), exist = exists) - if (.not. exists) then - errmsg = 'SCM data tendency :: namelist file: '//trim(nml_file)//' does not exist' - errflg = 1 - return - else - open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = scm_data_nml) - close (nlunit) - - ! ###################################################################################### - ! - ! Error checking - ! - ! ###################################################################################### - ! Only proceed if scheme simulator requested. - if (proc_SWRAD_config(1) .or. proc_LWRAD_config(1) .or. proc_PBL_config(1) .or. & - proc_GWD_config(1) .or. proc_SCNV_config(1) .or. proc_DCNV_config(1) .or. & - proc_cldMP_config(1)) then - do_ccpp_scheme_simulator = .true. - else - return - endif - - ! Check that input data file exists - inquire (file = trim (fileIN), exist = exists) - if (.not. exists) then - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' - errflg = 1 - return - endif - - ! ####################################################################################### - ! - ! Read mandatory information from data file... - ! (ONLY master processor(0), if MPI enabled) - ! - ! ####################################################################################### -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif - - ! Open file (required) - status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) - if (status /= nf90_noerr) then - errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) - errflg = 1 - return - endif - - ! Get dimensions (required) - status = nf90_inq_dimid(ncid, 'time', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [time] dimension' - errflg = 1 - return - endif - ! - status = nf90_inq_dimid(ncid, 'lev', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [lev] dimension' - errflg = 1 - return - endif -#ifdef MPI - endif ! On master processor - - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - - ! ####################################################################################### - ! - ! Broadcast dimensions... - ! (ALL processors) - ! - ! ####################################################################################### - call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_barrier(mpicomm, mpierr) - - if (mpirank .eq. mpiroot) then -#endif - - ! #################################################################################### - ! - ! What data fields do we have? - ! - ! #################################################################################### - - ! - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) have_dTdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) have_dqdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) have_dudt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) have_dvdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) have_dTdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) have_dudt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) have_dvdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) have_dTdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) have_dudt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) have_dvdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) have_dqdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) have_dTdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) have_dudt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) have_dvdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) have_dqdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) have_dTdt_cldMP_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) have_dqdt_cldMP_data = .true. - -#ifdef MPI - endif ! Master process -#endif - - ! Allocate space for data - allocate(time_data(ntime_data)) - if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) - if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data, nTrc)) - if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) - if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) - if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) - if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) - if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) - if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) - if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) - if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) - if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data, nTrc)) - if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) - if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) - if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) - if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data, nTrc)) - if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) - if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data, nTrc)) - - ! ####################################################################################### - ! - ! Read in data ... - ! (ONLY master processor(0), if MPI enabled) - ! - ! ####################################################################################### -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif - - ! Temporal info (required) - status = nf90_inq_varid(ncid, 'times', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, time_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' - errflg = 1 - return - endif - - ! Read in physics data tendencies (optional) - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) - ! - status = nf90_close(ncid) + ! Set to true in data was loaded into "physics_process" + logical :: do_ccpp_scheme_simulator=.false. -#ifdef MPI - endif ! Master process + public ccpp_scheme_simulator_run - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - ! ####################################################################################### - ! - ! Broadcast data... - ! (ALL processors) - ! - ! ####################################################################################### - - if (have_dTdt_LWRAD_data) then - call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SWRAD_data) then - call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_PBL_data) then - call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_PBL_data) then - call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_PBL_data) then - call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_PBL_data) then - call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_GWD_data) then - call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_GWD_data) then - call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_GWD_data) then - call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SCNV_data) then - call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_SCNV_data) then - call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_SCNV_data) then - call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_SCNV_data) then - call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_DCNV_data) then - call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_DCNV_data) then - call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_DCNV_data) then - call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_DCNV_data) then - call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_cldMP_data) then - call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_cldMP_data) then - call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - ! - call mpi_barrier(mpicomm, mpierr) -#endif - - ! ####################################################################################### - ! - ! Populate physics_process type. - ! - ! ####################################################################################### - - ! Allocate - allocate(physics_process(nPhysProcess)) - - ! Metadata - do iprc = 1,nPhysProcess - allocate(physics_process(iprc)%itend%dT(nlev_data)) - allocate(physics_process(iprc)%itend%du(nlev_data)) - allocate(physics_process(iprc)%itend%dv(nlev_data)) - allocate(physics_process(iprc)%itend%dq(nlev_data)) - if (iprc == proc_SWRAD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SWRAD" - if (proc_SWRAD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_SWRAD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_LWRAD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "LWRAD" - if (proc_LWRAD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_LWRAD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_GWD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "GWD" - if (proc_GWD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_GWD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_PBL_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "PBL" - if (proc_PBL_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_PBL_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_SCNV_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SCNV" - if (proc_SCNV_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_SCNV_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_DCNV_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "DCNV" - if (proc_DCNV_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_DCNV_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_cldMP_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "cldMP" - if (proc_cldMP_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_cldMP_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - enddo - - ! Load data - physics_process(proc_LWRAD_config(3))%tend%time => time_data - physics_process(proc_SWRAD_config(3))%tend%time => time_data - physics_process(proc_PBL_config(3))%tend%time => time_data - physics_process(proc_GWD_config(3))%tend%time => time_data - physics_process(proc_DCNV_config(3))%tend%time => time_data - physics_process(proc_SCNV_config(3))%tend%time => time_data - physics_process(proc_cldMP_config(3))%tend%time => time_data - if (have_dTdt_LWRAD_data) physics_process(proc_SWRAD_config(3))%tend%T => dTdt_LWRAD_data - if (have_dTdt_SWRAD_data) physics_process(proc_LWRAD_config(3))%tend%T => dTdt_SWRAD_data - if (have_dTdt_PBL_data) physics_process(proc_PBL_config(3))%tend%T => dTdt_PBL_data - if (have_dudt_PBL_data) physics_process(proc_PBL_config(3))%tend%u => dudt_PBL_data - if (have_dvdt_PBL_data) physics_process(proc_PBL_config(3))%tend%v => dvdt_PBL_data - if (have_dqdt_PBL_data) physics_process(proc_PBL_config(3))%tend%q => dqdt_PBL_data - if (have_dTdt_GWD_data) physics_process(proc_GWD_config(3))%tend%T => dTdt_GWD_data - if (have_dudt_GWD_data) physics_process(proc_GWD_config(3))%tend%u => dudt_GWD_data - if (have_dvdt_GWD_data) physics_process(proc_GWD_config(3))%tend%v => dvdt_GWD_data - if (have_dTdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%T => dTdt_SCNV_data - if (have_dudt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%u => dudt_SCNV_data - if (have_dvdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%v => dvdt_SCNV_data - if (have_dqdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend%q => dqdt_SCNV_data - if (have_dTdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%T => dTdt_DCNV_data - if (have_dudt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%u => dudt_DCNV_data - if (have_dvdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%v => dvdt_DCNV_data - if (have_dqdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend%q => dqdt_DCNV_data - if (have_dTdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend%T => dTdt_cldMP_data - if (have_dqdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend%q => dqdt_cldMP_data - - ! Which process-scheme is "Active"? - do iprc = 1,nPhysProcess - if (.not. physics_process(iprc)%use_sim) then - iactive_scheme = iprc - endif - enddo - - ! - if (mpirank .eq. mpiroot) then - print*, "----------------------------------" - print*, "--- Using CCPP data tendencies ---" - print*, "----------------------------------" - do iprc = 1,nPhysProcess - if (physics_process(iprc)%use_sim) then - print*," simulate_scheme: ", trim(physics_process(iprc)%name) - print*," order: ", physics_process(iprc)%order - print*," time_split: ", physics_process(iprc)%time_split - endif - enddo - print*, " active_scheme: ", trim(physics_process(iactive_scheme)%name) - print*, " order: ", physics_process(iactive_scheme)%order - print*, " time_split : ", physics_process(iactive_scheme)%time_split - print*, "----------------------------------" - print*, "----------------------------------" - endif - - end subroutine ccpp_scheme_simulator_init +contains ! ###################################################################################### ! @@ -662,7 +124,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Locals integer :: iCol, iLay, iTrc, nCol, nLay, nTrc, ti(1), tf(1), idtend, fcst_year, & - fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, iprc, index_of_process + fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, iprc, index_of_active_process real(kind_phys) :: w1, w2,hrofday real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt real(kind_phys), dimension(:,:,:), allocatable :: gq1, dqdt @@ -690,7 +152,27 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) - ! Set state + ! Get tendency for "active" process. + ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional + ! array, CCPP standard_name = cumulative_change_of_state_variables. + ! These are not the instantaneous physics tendencies that are applied to the state by the + ! physics schemes. Not all schemes output physics tendencies... + ! Rather these are intended for diagnostic puposes and are accumulated over some interval. + ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option "fhzero". + ! For this to work, you need to clear the diagnostic buckets after each physics timestep when + ! running in the UFS/SCM. + ! In the SCM this is done by adding the following runtime options: + ! --n_itt_out 1 --n_itt_diag 1 + ! + if (active_name == "LWRAD") index_of_active_process = index_of_process_longwave + if (active_name == "SWRAD") index_of_active_process = index_of_process_shortwave + if (active_name == "PBL") index_of_active_process = index_of_process_pbl + if (active_name == "GWD") index_of_active_process = index_of_process_orographic_gwd + if (active_name == "SCNV") index_of_active_process = index_of_process_scnv + if (active_name == "DCNV") index_of_active_process = index_of_process_dcnv + if (active_name == "cldMP") index_of_active_process = index_of_process_mp + + ! Set state at beginning of the physics timestep. gt1(:,:) = tgrs(:,:) gu1(:,:) = ugrs(:,:) gv1(:,:) = vgrs(:,:) @@ -700,70 +182,67 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dvdt(:,:) = 0. dqdt(:,:,1)= 0. - ! Model internal physics timestep evolution of "state". - do iprc = 1,nPhysProcess + ! Internal physics timestep evolution. + do iprc = proc_start,proc_end + if (iprc == iactive_scheme .and. active_time_split_process) then + proc_start = iactive_scheme + exit + endif + do iCol = 1,nCol ! Reset locals - physics_process(iprc)%itend%dT(:) = 0. - physics_process(iprc)%itend%du(:) = 0. - physics_process(iprc)%itend%dv(:) = 0. - physics_process(iprc)%itend%dq(:) = 0. + physics_process(iprc)%tend1d%T(:) = 0. + physics_process(iprc)%tend1d%u(:) = 0. + physics_process(iprc)%tend1d%v(:) = 0. + physics_process(iprc)%tend1d%q(:,1) = 0. ! Using scheme simulator (very simple, interpolate data tendency to local time) if (physics_process(iprc)%use_sim) then - if (associated(physics_process(iprc)%tend%T)) then + if (associated(physics_process(iprc)%tend2d%T)) then errmsg = physics_process(iprc)%linterp("T", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif - if (associated(physics_process(iprc)%tend%u)) then + if (associated(physics_process(iprc)%tend2d%u)) then errmsg = physics_process(iprc)%linterp("u", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif - if (associated(physics_process(iprc)%tend%v)) then + if (associated(physics_process(iprc)%tend2d%v)) then errmsg = physics_process(iprc)%linterp("v", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif - if (associated(physics_process(iprc)%tend%q)) then + if (associated(physics_process(iprc)%tend2d%q)) then errmsg = physics_process(iprc)%linterp("q", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) endif ! Using data tendency from "active" scheme(s). - ! DJS2023: This block is very ufs specific. Need to tidy this up. + ! DJS2023: This block is very ufs specific. See Note Above. else - if (physics_process(iprc)%name == "LWRAD") index_of_process = index_of_process_longwave - if (physics_process(iprc)%name == "SWRAD") index_of_process = index_of_process_shortwave - if (physics_process(iprc)%name == "PBL") index_of_process = index_of_process_pbl - if (physics_process(iprc)%name == "GWD") index_of_process = index_of_process_orographic_gwd - if (physics_process(iprc)%name == "SCNV") index_of_process = index_of_process_scnv - if (physics_process(iprc)%name == "DCNV") index_of_process = index_of_process_dcnv - if (physics_process(iprc)%name == "cldMP") index_of_process = index_of_process_mp - ! - idtend = dtidx(index_of_temperature,index_of_process) - if (idtend >= 1) physics_process(iprc)%itend%dT = dtend(iCol,:,idtend)/dtp + idtend = dtidx(index_of_temperature,index_of_active_process) + if (idtend >= 1) physics_process(iprc)%tend1d%T = dtend(iCol,:,idtend)/dtp ! - idtend = dtidx(index_of_x_wind,index_of_process) - if (idtend >= 1) physics_process(iprc)%itend%du = dtend(iCol,:,idtend)/dtp + idtend = dtidx(index_of_x_wind,index_of_active_process) + if (idtend >= 1) physics_process(iprc)%tend1d%u = dtend(iCol,:,idtend)/dtp ! - idtend = dtidx(index_of_y_wind,index_of_process) - if (idtend >= 1) physics_process(iprc)%itend%dv = dtend(iCol,:,idtend)/dtp + idtend = dtidx(index_of_y_wind,index_of_active_process) + if (idtend >= 1) physics_process(iprc)%tend1d%v = dtend(iCol,:,idtend)/dtp ! - idtend = dtidx(100+ntqv,index_of_process) - if (idtend >= 1) physics_process(iprc)%itend%dq = dtend(iCol,:,idtend)/dtp + idtend = dtidx(100+ntqv,index_of_active_process) + if (idtend >= 1) physics_process(iprc)%tend1d%q(:,1) = dtend(iCol,:,idtend)/dtp endif ! Update state now? if (physics_process(iprc)%time_split) then - gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%itend%dT)*dtp - gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%itend%du)*dtp - gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%itend%dv)*dtp - gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + physics_process(iprc)%itend%dq)*dtp + gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp + gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp + gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp + gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + physics_process(iprc)%tend1d%q(:,1))*dtp dTdt(iCol,:) = 0. dudt(iCol,:) = 0. dvdt(iCol,:) = 0. dqdt(iCol,:,1) = 0. ! Accumulate tendencies, update later? else - dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%itend%dT - dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%itend%du - dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%itend%dv - dqdt(iCol,:,1) = dqdt(iCol,:,1) + physics_process(iprc)%itend%dq + dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T + dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u + dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v + dqdt(iCol,:,1) = dqdt(iCol,:,1) + physics_process(iprc)%tend1d%q(:,1) endif enddo ! @@ -771,13 +250,18 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp gq0(iCol,:,1) = gq1(iCol,:,1) + dqdt(iCol,:,1)*dtp - enddo + + if (iprc == proc_end) then + proc_start = 1 + endif ! end subroutine ccpp_scheme_simulator_run ! #################################################################################### - ! Utility functions/routines + ! Type-bound procedure to compute tendency profile for time-of-day. + ! + ! For use with 1D data (level, time) tendencies with diurnal (24-hr) forcing. ! #################################################################################### function linterp_1D(this, var_name, year, month, day, hour, minute, second) result(err_message) class(base_physics_process), intent(inout) :: this @@ -785,27 +269,92 @@ function linterp_1D(this, var_name, year, month, day, hour, minute, second) resu integer, intent(in) :: year, month, day, hour, minute, second character(len=128) :: err_message integer :: ti(1), tf(1) - real(kind_phys) :: w1, w2, hrofday + real(kind_phys) :: w1, w2 ! Interpolation weights - hrofday = hour*3600. + minute*60. + second - ti = findloc(abs(this%tend%time-hrofday),minval(abs(this%tend%time-hrofday))) - if (hrofday - this%tend%time(ti(1)) .le. 0) ti = ti-1 - tf = ti + 1 - w1 = (this%tend%time(tf(1))-hrofday) / (this%tend%time(tf(1)) - this%tend%time(ti(1))) - w2 = 1 - w1 + call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) select case(var_name) case("T") - this%itend%dT = w1*this%tend%T(:,ti(1)) + w2*this%tend%T(:,tf(1)) + this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) case("u") - this%itend%du = w1*this%tend%u(:,ti(1)) + w2*this%tend%u(:,tf(1)) + this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) case("v") - this%itend%dv = w1*this%tend%v(:,ti(1)) + w2*this%tend%v(:,tf(1)) + this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) case("q") - this%itend%dq = w1*this%tend%q(:,ti(1),1) + w2*this%tend%q(:,tf(1),1) + this%tend1d%q(:,1) = w1*this%tend2d%q(:,ti(1),1) + w2*this%tend2d%q(:,tf(1),1) end select end function linterp_1D - + + ! #################################################################################### + ! Type-bound procedure to compute tendency profile for time-of-day. + ! + ! For use with 2D data (location, level, time) tendencies with diurnal (24-hr) forcing. + ! This assumes that the location dimension has a [longitude, latitude] associated with + ! each location. + ! #################################################################################### + function linterp_2D(this, var_name, lon, lat, year, month, day, hour, minute, second) result(err_message) + class(base_physics_process), intent(inout) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: year, month, day, hour, minute, second + real(kind_phys), intent(in) :: lon, lat + character(len=128) :: err_message + integer :: ti(1), tf(1), iNearest + real(kind_phys) :: w1, w2 + + ! Interpolation weights (temporal) + call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) + + ! Grab data tendency closest to column [lon,lat] + iNearest = this%find_nearest_loc_2d_1d(lon,lat) + + select case(var_name) + case("T") + this%tend1d%T = w1*this%tend3d%T(iNearest,:,ti(1)) + w2*this%tend3d%T(iNearest,:,tf(1)) + case("u") + this%tend1d%u = w1*this%tend3d%u(iNearest,:,ti(1)) + w2*this%tend3d%u(iNearest,:,tf(1)) + case("v") + this%tend1d%v = w1*this%tend3d%v(iNearest,:,ti(1)) + w2*this%tend3d%v(iNearest,:,tf(1)) + case("q") + this%tend1d%q(:,1) = w1*this%tend3d%q(iNearest,:,ti(1),1) + w2*this%tend3d%q(iNearest,:,tf(1),1) + end select + end function linterp_2D + + ! #################################################################################### + ! Type-bound procedure to find nearest location. + ! + ! For use with linterp_2D, NOT YET IMPLEMENTED. + ! #################################################################################### + pure function find_nearest_loc_2d_1d(this, lon, lat) + class(base_physics_process), intent(in) :: this + real(kind_phys), intent(in) :: lon, lat + integer :: find_nearest_loc_2d_1d + + find_nearest_loc_2d_1d = 1 + end function find_nearest_loc_2d_1d + + ! #################################################################################### + ! Type-bound procedure to compute linear interpolation weights for a diurnal (24-hour) + ! forcing. + ! #################################################################################### + subroutine cmp_time_wts(this, year, month, day, hour, minute, second, w1, w2, ti, tf) + ! Inputs + class(base_physics_process), intent(in) :: this + integer, intent(in) :: year, month, day, hour, minute, second + ! Outputs + integer,intent(out) :: ti(1), tf(1) + real(kind_phys),intent(out) :: w1, w2 + ! Locals + real(kind_phys) :: hrofday + + hrofday = hour*3600. + minute*60. + second + ti = findloc(abs(this%tend2d%time-hrofday),minval(abs(this%tend2d%time-hrofday))) + if (hrofday - this%tend2d%time(ti(1)) .le. 0) ti = ti-1 + tf = ti + 1 + w1 = (this%tend2d%time(tf(1))-hrofday) / (this%tend2d%time(tf(1)) - this%tend2d%time(ti(1))) + w2 = 1 - w1 + + end subroutine cmp_time_wts + end module ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 80f898ed2..02bf17285 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -3,62 +3,6 @@ type = scheme dependencies = machine.F -######################################################################## -[ccpp-arg-table] - name = ccpp_scheme_simulator_init - type = scheme -[mpirank] - standard_name = mpi_rank - long_name = MPI rank of current process - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = MPI rank of master process - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[nlunit] - standard_name = iounit_of_namelist - long_name = fortran unit number for opening nameliust file - units = none - dimensions = () - type = integer - intent = in -[nml_file] - standard_name = filename_of_namelist - long_name = namelist filename - units = none - dimensions = () - type = character - kind = len=* - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - ######################################################################## [ccpp-arg-table] name = ccpp_scheme_simulator_run diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 new file mode 100644 index 000000000..1041e113c --- /dev/null +++ b/physics/load_ccpp_scheme_sim.F90 @@ -0,0 +1,577 @@ +! ######################################################################################## +! +! CCPP scheme to read and load data for ccpp_scheme_simulator +! +! ######################################################################################## +module load_ccpp_scheme_sim + use machine, only: kind_phys + use netcdf + use ccpp_scheme_simulator, only: do_ccpp_scheme_simulator, physics_process, active_name,& + iactive_scheme, proc_start, proc_end, active_time_split_process +#ifdef MPI + use mpi +#endif + implicit none + + ! ######################################################################################## + ! + ! Configuration for CCPP scheme simulator. Set in namelist. Used during initialization to + ! populate "physics_process" type array, defined in ccpp_scheme_simulator.F90 + ! + ! ######################################################################################## + + ! Number of physics process (set in namelist) + integer :: nPhysProcess + + ! For each process there is a corresponding namelist entry, which is constructed as follows: + ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} + integer, dimension(3) :: & + proc_LWRAD_config = (/0,0,0/), & + proc_SWRAD_config = (/0,0,0/), & + proc_PBL_config = (/0,0,0/), & + proc_GWD_config = (/0,0,0/), & + proc_SCNV_config = (/0,0,0/), & + proc_DCNV_config = (/0,0,0/), & + proc_cldMP_config = (/0,0,0/) + + ! Activation flag for scheme. + logical :: do_load_ccpp_scheme = .false. + + ! Data driven physics tendencies + integer :: nlev_data, ntime_data + real(kind_phys), allocatable, dimension(:), target :: time_data + real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & + dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & + dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & + dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data + real(kind_phys), allocatable, dimension(:,:,:), target :: dqdt_PBL_data, & + dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data + + ! Scheme initialization flag. + logical :: module_initialized = .false. + + public load_ccpp_scheme_sim_init +contains + + ! ###################################################################################### + ! + ! SUBROUTINE load_ccpp_scheme_sim_init + ! + ! ###################################################################################### +!! \section arg_table_load_ccpp_scheme_sim_init +!! \htmlinclude load_ccpp_scheme_sim_init.html +!! + subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, & + errmsg, errflg) + + ! Inputs + integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit + character(len=*), intent (in) :: nml_file + + ! Outputs + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc + character(len=256) :: fileIN + logical :: exists + integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality + + ! Switches for input data + logical :: have_dTdt_LWRAD_data = .false., & + have_dTdt_SWRAD_data = .false., & + have_dTdt_PBL_data = .false., & + have_dqdt_PBL_data = .false., & + have_dudt_PBL_data = .false., & + have_dvdt_PBL_data = .false., & + have_dTdt_GWD_data = .false., & + have_dudt_GWD_data = .false., & + have_dvdt_GWD_data = .false., & + have_dTdt_SCNV_data = .false., & + have_dudt_SCNV_data = .false., & + have_dvdt_SCNV_data = .false., & + have_dqdt_SCNV_data = .false., & + have_dTdt_DCNV_data = .false., & + have_dudt_DCNV_data = .false., & + have_dvdt_DCNV_data = .false., & + have_dqdt_DCNV_data = .false., & + have_dTdt_cldMP_data = .false., & + have_dqdt_cldMP_data = .false. + + ! Namelist + namelist / scm_data_nml / fileIN, nPhysProcess, proc_LWRAD_config, proc_SWRAD_config, & + proc_PBL_config, proc_GWD_config, proc_SCNV_config, proc_DCNV_config, & + proc_cldMP_config + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (module_initialized) return + module_initialized = .true. + + ! ###################################################################################### + ! + ! Part A) Read in namelist and data. + ! + ! ###################################################################################### + + ! Read in namelist + inquire (file = trim (nml_file), exist = exists) + if (.not. exists) then + errmsg = 'SCM data tendency :: namelist file: '//trim(nml_file)//' does not exist' + errflg = 1 + return + else + open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = scm_data_nml) + close (nlunit) + + ! Only proceed if scheme simulator requested. + if (proc_SWRAD_config(1) .or. proc_LWRAD_config(1) .or. proc_PBL_config(1) .or. & + proc_GWD_config(1) .or. proc_SCNV_config(1) .or. proc_DCNV_config(1) .or. & + proc_cldMP_config(1)) then + do_ccpp_scheme_simulator = .true. + else + return + endif + + ! Check that input data file exists + inquire (file = trim (fileIN), exist = exists) + if (.not. exists) then + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' + errflg = 1 + return + endif + + ! Read mandatory information from data file... + ! (ONLY master processor(0), if MPI enabled) +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Open file (required) + status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) + errflg = 1 + return + endif + + ! Get dimensions (required) + status = nf90_inq_dimid(ncid, 'time', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [time] dimension' + errflg = 1 + return + endif + ! + status = nf90_inq_dimid(ncid, 'lev', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [lev] dimension' + errflg = 1 + return + endif +#ifdef MPI + endif ! On master processor + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! Broadcast dimensions... + ! (ALL processors) + call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_barrier(mpicomm, mpierr) + + if (mpirank .eq. mpiroot) then +#endif + + ! + ! What data fields do we have? + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) have_dTdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) have_dqdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) have_dudt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) have_dvdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) have_dTdt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) have_dudt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) have_dvdt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) have_dTdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) have_dudt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) have_dvdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) have_dqdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) have_dTdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) have_dudt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) have_dvdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) have_dqdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) have_dTdt_cldMP_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) have_dqdt_cldMP_data = .true. + +#ifdef MPI + endif ! Master process +#endif + + ! Allocate space for data + allocate(time_data(ntime_data)) + if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) + if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data, nTrc)) + if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) + if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) + if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) + if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) + if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) + if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) + if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) + if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) + if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) + if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) + if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) + if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) + if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data, nTrc)) + + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Temporal info (required) + status = nf90_inq_varid(ncid, 'times', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, time_data) + else + errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' + errflg = 1 + return + endif + + ! Read in physics data tendencies (optional) + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) + ! + status = nf90_close(ncid) + +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! Broadcast data... + ! (ALL processors) + if (have_dTdt_LWRAD_data) then + call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_SWRAD_data) then + call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_PBL_data) then + call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_PBL_data) then + call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_PBL_data) then + call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_PBL_data) then + call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_GWD_data) then + call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_GWD_data) then + call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_GWD_data) then + call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_SCNV_data) then + call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_SCNV_data) then + call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_SCNV_data) then + call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_SCNV_data) then + call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_DCNV_data) then + call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_DCNV_data) then + call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_DCNV_data) then + call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_DCNV_data) then + call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_cldMP_data) then + call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_cldMP_data) then + call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + ! + call mpi_barrier(mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! + ! Part B) Populate physics_process type. + ! + ! ####################################################################################### + ! Default process extent (no time-split physics processes) + proc_start = 1 + proc_end = nPhysProcess + + ! Allocate + allocate(physics_process(nPhysProcess)) + + ! Metadata + do iprc = 1,nPhysProcess + allocate(physics_process(iprc)%tend1d%T(nlev_data)) + allocate(physics_process(iprc)%tend1d%u(nlev_data)) + allocate(physics_process(iprc)%tend1d%v(nlev_data)) + allocate(physics_process(iprc)%tend1d%q(nlev_data,1)) + if (iprc == proc_SWRAD_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SWRAD" + if (proc_SWRAD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_SWRAD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_LWRAD_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "LWRAD" + if (proc_LWRAD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_LWRAD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_GWD_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "GWD" + if (proc_GWD_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_GWD_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_PBL_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "PBL" + if (proc_PBL_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_PBL_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_SCNV_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SCNV" + if (proc_SCNV_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_SCNV_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_DCNV_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "DCNV" + if (proc_DCNV_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_DCNV_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == proc_cldMP_config(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "cldMP" + if (proc_cldMP_config(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (proc_cldMP_config(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + enddo + + ! Load data + physics_process(proc_LWRAD_config(3))%tend2d%time => time_data + physics_process(proc_SWRAD_config(3))%tend2d%time => time_data + physics_process(proc_PBL_config(3))%tend2d%time => time_data + physics_process(proc_GWD_config(3))%tend2d%time => time_data + physics_process(proc_DCNV_config(3))%tend2d%time => time_data + physics_process(proc_SCNV_config(3))%tend2d%time => time_data + physics_process(proc_cldMP_config(3))%tend2d%time => time_data + if (have_dTdt_LWRAD_data) physics_process(proc_SWRAD_config(3))%tend2d%T => dTdt_LWRAD_data + if (have_dTdt_SWRAD_data) physics_process(proc_LWRAD_config(3))%tend2d%T => dTdt_SWRAD_data + if (have_dTdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%T => dTdt_PBL_data + if (have_dudt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%u => dudt_PBL_data + if (have_dvdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%v => dvdt_PBL_data + if (have_dqdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%q => dqdt_PBL_data + if (have_dTdt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%T => dTdt_GWD_data + if (have_dudt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%u => dudt_GWD_data + if (have_dvdt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%v => dvdt_GWD_data + if (have_dTdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%T => dTdt_SCNV_data + if (have_dudt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%u => dudt_SCNV_data + if (have_dvdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%v => dvdt_SCNV_data + if (have_dqdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%q => dqdt_SCNV_data + if (have_dTdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%T => dTdt_DCNV_data + if (have_dudt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%u => dudt_DCNV_data + if (have_dvdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%v => dvdt_DCNV_data + if (have_dqdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%q => dqdt_DCNV_data + if (have_dTdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%T => dTdt_cldMP_data + if (have_dqdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%q => dqdt_cldMP_data + + ! Which process-scheme is "Active"? Is it a time-split process? + do iprc = 1,nPhysProcess + if (.not. physics_process(iprc)%use_sim) then + iactive_scheme = iprc + active_name = physics_process(iprc)%name + if (physics_process(iprc)%time_split) then + active_time_split_process = .true. + endif + endif + enddo + + ! + if (mpirank .eq. mpiroot) then + print*, "-----------------------------------" + print*, "--- Using CCPP scheme simulator ---" + print*, "-----------------------------------" + do iprc = 1,nPhysProcess + if (physics_process(iprc)%use_sim) then + print*," simulate_scheme: ", trim(physics_process(iprc)%name) + print*," order: ", physics_process(iprc)%order + print*," time_split: ", physics_process(iprc)%time_split + endif + enddo + print*, " active_scheme: ", trim(active_name) + print*, " order: ", physics_process(iactive_scheme)%order + print*, " time_split : ", active_time_split_process + print*, "-----------------------------------" + print*, "-----------------------------------" + endif + + end subroutine load_ccpp_scheme_sim_init + +end module load_ccpp_scheme_sim diff --git a/physics/load_ccpp_scheme_sim.meta b/physics/load_ccpp_scheme_sim.meta new file mode 100644 index 000000000..6e0aea925 --- /dev/null +++ b/physics/load_ccpp_scheme_sim.meta @@ -0,0 +1,60 @@ +[ccpp-table-properties] + name = load_ccpp_scheme_sim + type = scheme + dependencies = machine.F,ccpp_scheme_simulator.F90 + +######################################################################## +[ccpp-arg-table] + name = load_ccpp_scheme_sim_init + type = scheme +[mpirank] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[nlunit] + standard_name = iounit_of_namelist + long_name = fortran unit number for opening nameliust file + units = none + dimensions = () + type = integer + intent = in +[nml_file] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out From 8bc8ec909ea493714aa9c8325cd5bb93ef204225 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 13 Feb 2023 11:15:06 -0700 Subject: [PATCH 12/64] Small bug fix to nml --- physics/load_ccpp_scheme_sim.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 index 1041e113c..db2181cf3 100644 --- a/physics/load_ccpp_scheme_sim.F90 +++ b/physics/load_ccpp_scheme_sim.F90 @@ -127,7 +127,7 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) endif rewind (nlunit) - read (nlunit, nml = scm_data_nml) + read (nlunit, nml = scm_data_nml, iostat=status) close (nlunit) ! Only proceed if scheme simulator requested. From 6db4af5baeb306f24466bc601b0b42e787f6cb0c Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 13 Feb 2023 16:52:20 -0700 Subject: [PATCH 13/64] Remove dimension for tracer, handle tracers individualy, not with stacked array --- physics/ccpp_scheme_simulator.F90 | 126 +++++++++++++++-------------- physics/ccpp_scheme_simulator.meta | 4 +- physics/load_ccpp_scheme_sim.F90 | 13 +-- 3 files changed, 74 insertions(+), 69 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 3b478844f..4fffc8bb5 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -15,41 +15,41 @@ module ccpp_scheme_simulator ! ######################################################################################## ! Type containing 1D (time) physics tendencies. type phys_tend_1d - real(kind_phys), dimension(:), pointer :: T - real(kind_phys), dimension(:), pointer :: u - real(kind_phys), dimension(:), pointer :: v - real(kind_phys), dimension(:,:), pointer :: q + real(kind_phys), dimension(:), pointer :: T + real(kind_phys), dimension(:), pointer :: u + real(kind_phys), dimension(:), pointer :: v + real(kind_phys), dimension(:), pointer :: q end type phys_tend_1d ! Type containing 2D (lev,time) physics tendencies. type phys_tend_2d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: T - real(kind_phys), dimension(:,:), pointer :: u - real(kind_phys), dimension(:,:), pointer :: v - real(kind_phys), dimension(:,:,:), pointer :: q + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:,:), pointer :: T + real(kind_phys), dimension(:,:), pointer :: u + real(kind_phys), dimension(:,:), pointer :: v + real(kind_phys), dimension(:,:), pointer :: q end type phys_tend_2d ! Type containing 3D (loc,lev,time) physics tendencies. type phys_tend_3d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:), pointer :: lon - real(kind_phys), dimension(:), pointer :: lat - real(kind_phys), dimension(:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:,:), pointer :: q + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:), pointer :: lon + real(kind_phys), dimension(:), pointer :: lat + real(kind_phys), dimension(:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:), pointer :: q end type phys_tend_3d ! Type containing 4D (lon, lat,lev,time) physics tendencies. type phys_tend_4d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: lon - real(kind_phys), dimension(:,:), pointer :: lat - real(kind_phys), dimension(:,:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:,:,:), pointer :: q + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:,:), pointer :: lon + real(kind_phys), dimension(:,:), pointer :: lat + real(kind_phys), dimension(:,:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:,:), pointer :: q end type phys_tend_4d ! This type contains the meta information and data for each physics process. @@ -118,16 +118,16 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Outputs real(kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 - real(kind_phys), intent(inout), dimension(:,:,:) :: gq0 + real(kind_phys), intent(inout), dimension(:,:) :: gq0 character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg ! Locals - integer :: iCol, iLay, iTrc, nCol, nLay, nTrc, ti(1), tf(1), idtend, fcst_year, & - fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec, iprc, index_of_active_process + integer :: iCol, iLay, nCol, nLay, idtend, fcst_year, fcst_month, fcst_day, & + fcst_hour, fcst_min, fcst_sec, iprc, index_of_active_process real(kind_phys) :: w1, w2,hrofday - real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt - real(kind_phys), dimension(:,:,:), allocatable :: gq1, dqdt + real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt + real(kind_phys), dimension(:,:), allocatable :: gq1, dqdt ! Initialize CCPP error handling variables errmsg = '' @@ -144,13 +144,12 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti fcst_sec = jdat(7) ! Dimensions - nCol = size(gq0(:,1,1)) - nLay = size(gq0(1,:,1)) - nTrc = size(gq0(1,1,:)) + nCol = size(gq0(:,1)) + nLay = size(gq0(1,:)) ! Allocate temporaries - allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay,1)) - allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay,1)) + allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay)) + allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay)) ! Get tendency for "active" process. ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional @@ -173,14 +172,14 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (active_name == "cldMP") index_of_active_process = index_of_process_mp ! Set state at beginning of the physics timestep. - gt1(:,:) = tgrs(:,:) - gu1(:,:) = ugrs(:,:) - gv1(:,:) = vgrs(:,:) - gq1(:,:,1) = qgrs(:,:,1) - dTdt(:,:) = 0. - dudt(:,:) = 0. - dvdt(:,:) = 0. - dqdt(:,:,1)= 0. + gt1(:,:) = tgrs(:,:) + gu1(:,:) = ugrs(:,:) + gv1(:,:) = vgrs(:,:) + gq1(:,:) = qgrs(:,:,1) + dTdt(:,:) = 0. + dudt(:,:) = 0. + dvdt(:,:) = 0. + dqdt(:,:) = 0. ! Internal physics timestep evolution. do iprc = proc_start,proc_end @@ -188,13 +187,14 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti proc_start = iactive_scheme exit endif + print*,'Simulating ',iprc,' of ',proc_end do iCol = 1,nCol ! Reset locals physics_process(iprc)%tend1d%T(:) = 0. physics_process(iprc)%tend1d%u(:) = 0. physics_process(iprc)%tend1d%v(:) = 0. - physics_process(iprc)%tend1d%q(:,1) = 0. + physics_process(iprc)%tend1d%q(:) = 0. ! Using scheme simulator (very simple, interpolate data tendency to local time) if (physics_process(iprc)%use_sim) then @@ -224,32 +224,35 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (idtend >= 1) physics_process(iprc)%tend1d%v = dtend(iCol,:,idtend)/dtp ! idtend = dtidx(100+ntqv,index_of_active_process) - if (idtend >= 1) physics_process(iprc)%tend1d%q(:,1) = dtend(iCol,:,idtend)/dtp + if (idtend >= 1) physics_process(iprc)%tend1d%q = dtend(iCol,:,idtend)/dtp endif ! Update state now? if (physics_process(iprc)%time_split) then - gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp - gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp - gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp - gq1(iCol,:,1) = gq1(iCol,:,1) + (dqdt(iCol,:,1) + physics_process(iprc)%tend1d%q(:,1))*dtp - dTdt(iCol,:) = 0. - dudt(iCol,:) = 0. - dvdt(iCol,:) = 0. - dqdt(iCol,:,1) = 0. + gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp + gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp + gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp + gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp + dTdt(iCol,:) = 0. + dudt(iCol,:) = 0. + dvdt(iCol,:) = 0. + dqdt(iCol,:) = 0. ! Accumulate tendencies, update later? else - dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T - dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u - dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v - dqdt(iCol,:,1) = dqdt(iCol,:,1) + physics_process(iprc)%tend1d%q(:,1) + dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T + dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u + dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v + dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q endif enddo ! - gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp - gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp - gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp - gq0(iCol,:,1) = gq1(iCol,:,1) + dqdt(iCol,:,1)*dtp + do iLay=1,nLay + write(*,'(i3,6f13.6)') ilay, gt0(iCol,iLay) , gt1(iCol,iLay) , dTdt(iCol,iLay)*dtp,physics_process(iprc)%tend1d%T(iLay),physics_process(iprc)%tend2d%T(iLay,3),physics_process(iprc)%tend2d%T(iLay,4) + enddo + gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp + gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp + gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp + gq0(iCol,:) = gq1(iCol,:) + dqdt(iCol,:)*dtp enddo if (iprc == proc_end) then @@ -273,6 +276,7 @@ function linterp_1D(this, var_name, year, month, day, hour, minute, second) resu ! Interpolation weights call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) + print*,w1,w2,ti,tf select case(var_name) case("T") @@ -282,7 +286,7 @@ function linterp_1D(this, var_name, year, month, day, hour, minute, second) resu case("v") this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) case("q") - this%tend1d%q(:,1) = w1*this%tend2d%q(:,ti(1),1) + w2*this%tend2d%q(:,tf(1),1) + this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) end select end function linterp_1D @@ -317,7 +321,7 @@ function linterp_2D(this, var_name, lon, lat, year, month, day, hour, minute, se case("v") this%tend1d%v = w1*this%tend3d%v(iNearest,:,ti(1)) + w2*this%tend3d%v(iNearest,:,tf(1)) case("q") - this%tend1d%q(:,1) = w1*this%tend3d%q(iNearest,:,ti(1),1) + w2*this%tend3d%q(iNearest,:,tf(1),1) + this%tend1d%q = w1*this%tend3d%q(iNearest,:,ti(1)) + w2*this%tend3d%q(iNearest,:,tf(1)) end select end function linterp_2D diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 02bf17285..c0dc2f172 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -178,10 +178,10 @@ kind = kind_phys intent = inout [gq0] - standard_name = tracer_concentration_of_new_state + standard_name = specific_humidity_of_new_state long_name = tracer concentration updated by physics units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) + dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 index db2181cf3..b23c15839 100644 --- a/physics/load_ccpp_scheme_sim.F90 +++ b/physics/load_ccpp_scheme_sim.F90 @@ -44,7 +44,7 @@ module load_ccpp_scheme_sim dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:,:), target :: dqdt_PBL_data, & + real(kind_phys), allocatable, dimension(:,:), target :: dqdt_PBL_data, & dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data ! Scheme initialization flag. @@ -262,7 +262,7 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) - if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data, nTrc)) + if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data)) if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) @@ -271,13 +271,13 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) - if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data)) if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) - if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data, nTrc)) + if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data)) if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) - if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data, nTrc)) + if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data)) ! Read in data ... ! (ONLY master processor(0), if MPI enabled) @@ -301,6 +301,7 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file ! status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) + print*,'dTdt_SWRAD_data: ',dTdt_SWRAD_data ! status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) @@ -441,7 +442,7 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file allocate(physics_process(iprc)%tend1d%T(nlev_data)) allocate(physics_process(iprc)%tend1d%u(nlev_data)) allocate(physics_process(iprc)%tend1d%v(nlev_data)) - allocate(physics_process(iprc)%tend1d%q(nlev_data,1)) + allocate(physics_process(iprc)%tend1d%q(nlev_data)) if (iprc == proc_SWRAD_config(3)) then physics_process(iprc)%order = iprc physics_process(iprc)%name = "SWRAD" From 147cbac00de18dbf4d705d235ec90fcde9dd4ba3 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 13 Feb 2023 21:33:15 -0700 Subject: [PATCH 14/64] Fixed bug in interpolation routine. --- physics/ccpp_scheme_simulator.F90 | 57 +++++++++++++++++++++--------- physics/ccpp_scheme_simulator.meta | 16 +++++++++ physics/load_ccpp_scheme_sim.F90 | 5 +-- 3 files changed, 57 insertions(+), 21 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 4fffc8bb5..957a97862 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -82,6 +82,8 @@ module ccpp_scheme_simulator integer :: iactive_scheme integer :: proc_start, proc_end logical :: active_time_split_process=.false. + logical :: in_pre_active = .true. + logical :: in_post_active = .false. ! Set to true in data was loaded into "physics_process" logical :: do_ccpp_scheme_simulator=.false. @@ -103,7 +105,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gt0, gu0, gv0, gq0, & - errmsg, errflg) + dtdq_pbl, dtdq_mp, errmsg, errflg) ! Inputs integer, intent(in) :: kdt, ntqv, index_of_process_dcnv, & @@ -118,7 +120,7 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Outputs real(kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 - real(kind_phys), intent(inout), dimension(:,:) :: gq0 + real(kind_phys), intent(inout), dimension(:,:) :: gq0, dtdq_pbl, dtdq_mp character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg @@ -181,13 +183,22 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dvdt(:,:) = 0. dqdt(:,:) = 0. + if (in_pre_active) then + proc_start = 1 + proc_end = iactive_scheme-1 + endif + if (in_post_active) then + proc_start = iactive_scheme + proc_end = size(physics_process) + endif + ! Internal physics timestep evolution. do iprc = proc_start,proc_end if (iprc == iactive_scheme .and. active_time_split_process) then - proc_start = iactive_scheme - exit + print*,'Reached active process. ', iprc + else + print*,'Simulating ',iprc,' of ',proc_end endif - print*,'Simulating ',iprc,' of ',proc_end do iCol = 1,nCol ! Reset locals @@ -233,10 +244,10 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp - dTdt(iCol,:) = 0. - dudt(iCol,:) = 0. - dvdt(iCol,:) = 0. - dqdt(iCol,:) = 0. + !dTdt(iCol,:) = 0. + !dudt(iCol,:) = 0. + !dvdt(iCol,:) = 0. + !dqdt(iCol,:) = 0. ! Accumulate tendencies, update later? else dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T @@ -244,10 +255,17 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q endif + ! These are needed by samfshalcnv + if (trim(physics_process(iprc)%name) == "PBL") then + dtdq_pbl(iCol,:) = physics_process(iprc)%tend1d%q + endif + if (trim(physics_process(iprc)%name) == "cldMP") then + dtdq_mp(iCol,:) = physics_process(iprc)%tend1d%q + endif enddo ! do iLay=1,nLay - write(*,'(i3,6f13.6)') ilay, gt0(iCol,iLay) , gt1(iCol,iLay) , dTdt(iCol,iLay)*dtp,physics_process(iprc)%tend1d%T(iLay),physics_process(iprc)%tend2d%T(iLay,3),physics_process(iprc)%tend2d%T(iLay,4) + !write(*,'(i3,4f13.6)') ilay, gq0(iCol,iLay) , gq1(iCol,iLay) , dqdt(iCol,iLay)*dtp, physics_process(iprc)%tend1d%q(iLay)*dtp enddo gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp @@ -255,9 +273,16 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti gq0(iCol,:) = gq1(iCol,:) + dqdt(iCol,:)*dtp enddo - if (iprc == proc_end) then - proc_start = 1 + if (in_pre_active) then + in_pre_active = .false. + in_post_active = .true. endif + + if (size(physics_process)+1 == iprc) then + in_pre_active = .true. + in_post_active = .false. + endif + ! end subroutine ccpp_scheme_simulator_run @@ -276,7 +301,6 @@ function linterp_1D(this, var_name, year, month, day, hour, minute, second) resu ! Interpolation weights call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) - print*,w1,w2,ti,tf select case(var_name) case("T") @@ -353,10 +377,9 @@ subroutine cmp_time_wts(this, year, month, day, hour, minute, second, w1, w2, ti real(kind_phys) :: hrofday hrofday = hour*3600. + minute*60. + second - ti = findloc(abs(this%tend2d%time-hrofday),minval(abs(this%tend2d%time-hrofday))) - if (hrofday - this%tend2d%time(ti(1)) .le. 0) ti = ti-1 - tf = ti + 1 - w1 = (this%tend2d%time(tf(1))-hrofday) / (this%tend2d%time(tf(1)) - this%tend2d%time(ti(1))) + ti = max(hour,1) + tf = min(ti + 1,24) + w1 = ((hour+1)*3600 - hrofday)/3600 w2 = 1 - w1 end subroutine cmp_time_wts diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index c0dc2f172..888ba2f8d 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -185,6 +185,22 @@ type = real kind = kind_phys intent = inout +[dtdq_pbl] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[dtdq_mp] + standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics + long_name = moisture tendency due to microphysics + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 index b23c15839..8f4c7ee57 100644 --- a/physics/load_ccpp_scheme_sim.F90 +++ b/physics/load_ccpp_scheme_sim.F90 @@ -7,7 +7,7 @@ module load_ccpp_scheme_sim use machine, only: kind_phys use netcdf use ccpp_scheme_simulator, only: do_ccpp_scheme_simulator, physics_process, active_name,& - iactive_scheme, proc_start, proc_end, active_time_split_process + iactive_scheme, active_time_split_process #ifdef MPI use mpi #endif @@ -430,9 +430,6 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file ! Part B) Populate physics_process type. ! ! ####################################################################################### - ! Default process extent (no time-split physics processes) - proc_start = 1 - proc_end = nPhysProcess ! Allocate allocate(physics_process(nPhysProcess)) From a29638959bf2202d3132b8e5ae57db7774213f1d Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 16 Feb 2023 21:02:27 -0700 Subject: [PATCH 15/64] Moew changes --- physics/ccpp_scheme_simulator.F90 | 230 +++++++++++++++++++++++------- physics/load_ccpp_scheme_sim.F90 | 31 ++-- 2 files changed, 203 insertions(+), 58 deletions(-) diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 957a97862..f75580fb9 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -74,14 +74,18 @@ module ccpp_scheme_simulator type(base_physics_process), dimension(:), allocatable :: & physics_process + ! Do not change these! ! For time-split physics process we need to call this scheme twice in the SDF, once ! before the "active" scheme is called, and once after. This is because the active ! scheme uses an internal physics state that has been advanced forward by a subsequent ! physics process(es). - character(len=16) :: active_name - integer :: iactive_scheme + integer :: nactive_proc + character(len=16),allocatable,dimension(:) :: active_name + integer,allocatable,dimension(:) :: iactive_scheme + logical,allocatable,dimension(:) :: active_time_split_process + integer :: iactive_scheme_inloop = 1 + integer :: proc_start, proc_end - logical :: active_time_split_process=.false. logical :: in_pre_active = .true. logical :: in_post_active = .false. @@ -125,8 +129,8 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti integer, intent(out) :: errflg ! Locals - integer :: iCol, iLay, nCol, nLay, idtend, fcst_year, fcst_month, fcst_day, & - fcst_hour, fcst_min, fcst_sec, iprc, index_of_active_process + integer :: iCol, iLay, nCol, nLay, idtend, year, month, day, hour, min, sec, iprc, & + index_of_active_process real(kind_phys) :: w1, w2,hrofday real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt real(kind_phys), dimension(:,:), allocatable :: gq1, dqdt @@ -138,12 +142,12 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (.not. do_ccpp_scheme_simulator) return ! Current forecast time (Data-format specific) - fcst_year = jdat(1) - fcst_month = jdat(2) - fcst_day = jdat(3) - fcst_hour = jdat(5) - fcst_min = jdat(6) - fcst_sec = jdat(7) + year = jdat(1) + month = jdat(2) + day = jdat(3) + hour = jdat(5) + min = jdat(6) + sec = jdat(7) ! Dimensions nCol = size(gq0(:,1)) @@ -165,13 +169,13 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! In the SCM this is done by adding the following runtime options: ! --n_itt_out 1 --n_itt_diag 1 ! - if (active_name == "LWRAD") index_of_active_process = index_of_process_longwave - if (active_name == "SWRAD") index_of_active_process = index_of_process_shortwave - if (active_name == "PBL") index_of_active_process = index_of_process_pbl - if (active_name == "GWD") index_of_active_process = index_of_process_orographic_gwd - if (active_name == "SCNV") index_of_active_process = index_of_process_scnv - if (active_name == "DCNV") index_of_active_process = index_of_process_dcnv - if (active_name == "cldMP") index_of_active_process = index_of_process_mp + if (active_name(iactive_scheme_inloop) == "LWRAD") index_of_active_process = index_of_process_longwave + if (active_name(iactive_scheme_inloop) == "SWRAD") index_of_active_process = index_of_process_shortwave + if (active_name(iactive_scheme_inloop) == "PBL") index_of_active_process = index_of_process_pbl + if (active_name(iactive_scheme_inloop) == "GWD") index_of_active_process = index_of_process_orographic_gwd + if (active_name(iactive_scheme_inloop) == "SCNV") index_of_active_process = index_of_process_scnv + if (active_name(iactive_scheme_inloop) == "DCNV") index_of_active_process = index_of_process_dcnv + if (active_name(iactive_scheme_inloop) == "cldMP") index_of_active_process = index_of_process_mp ! Set state at beginning of the physics timestep. gt1(:,:) = tgrs(:,:) @@ -185,16 +189,16 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (in_pre_active) then proc_start = 1 - proc_end = iactive_scheme-1 + proc_end = max(1,iactive_scheme(iactive_scheme_inloop)-1) endif if (in_post_active) then - proc_start = iactive_scheme + proc_start = iactive_scheme(iactive_scheme_inloop) proc_end = size(physics_process) endif ! Internal physics timestep evolution. do iprc = proc_start,proc_end - if (iprc == iactive_scheme .and. active_time_split_process) then + if (iprc == iactive_scheme(iactive_scheme_inloop)) then print*,'Reached active process. ', iprc else print*,'Simulating ',iprc,' of ',proc_end @@ -209,17 +213,26 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Using scheme simulator (very simple, interpolate data tendency to local time) if (physics_process(iprc)%use_sim) then - if (associated(physics_process(iprc)%tend2d%T)) then - errmsg = physics_process(iprc)%linterp("T", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) + if (physics_process(iprc)%name == "LWRAD") then + call sim_LWRAD(year, month, day, hour, min, sec, physics_process(iprc)) + endif + if (physics_process(iprc)%name == "SWRAD")then + call sim_SWRAD(year, month, day, hour, min, sec, physics_process(iprc)) + endif + if (physics_process(iprc)%name == "GWD")then + call sim_GWD(year, month, day, hour, min, sec, physics_process(iprc)) + endif + if (physics_process(iprc)%name == "PBL")then + call sim_PBL(year, month, day, hour, min, sec, physics_process(iprc)) endif - if (associated(physics_process(iprc)%tend2d%u)) then - errmsg = physics_process(iprc)%linterp("u", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) + if (physics_process(iprc)%name == "SCNV")then + call sim_SCNV(year, month, day, hour, min, sec, physics_process(iprc)) endif - if (associated(physics_process(iprc)%tend2d%v)) then - errmsg = physics_process(iprc)%linterp("v", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) + if (physics_process(iprc)%name == "DCNV")then + call sim_DCNV(year, month, day, hour, min, sec, physics_process(iprc)) endif - if (associated(physics_process(iprc)%tend2d%q)) then - errmsg = physics_process(iprc)%linterp("q", fcst_year, fcst_month, fcst_day, fcst_hour, fcst_min, fcst_sec) + if (physics_process(iprc)%name == "cldMP")then + call sim_cldMP(year, month, day, hour, min, sec, physics_process(iprc)) endif ! Using data tendency from "active" scheme(s). @@ -240,28 +253,23 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti ! Update state now? if (physics_process(iprc)%time_split) then + print*,' time-split scheme...' gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp - !dTdt(iCol,:) = 0. - !dudt(iCol,:) = 0. - !dvdt(iCol,:) = 0. - !dqdt(iCol,:) = 0. + dTdt(iCol,:) = 0. + dudt(iCol,:) = 0. + dvdt(iCol,:) = 0. + dqdt(iCol,:) = 0. ! Accumulate tendencies, update later? else + print*,' process-split scheme...' dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q endif - ! These are needed by samfshalcnv - if (trim(physics_process(iprc)%name) == "PBL") then - dtdq_pbl(iCol,:) = physics_process(iprc)%tend1d%q - endif - if (trim(physics_process(iprc)%name) == "cldMP") then - dtdq_mp(iCol,:) = physics_process(iprc)%tend1d%q - endif enddo ! do iLay=1,nLay @@ -281,6 +289,11 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti if (size(physics_process)+1 == iprc) then in_pre_active = .true. in_post_active = .false. + iactive_scheme_inloop = 1 + endif + + if (iactive_scheme_inloop < nactive_proc) then + iactive_scheme_inloop = iactive_scheme_inloop + 1 endif ! @@ -291,16 +304,16 @@ end subroutine ccpp_scheme_simulator_run ! ! For use with 1D data (level, time) tendencies with diurnal (24-hr) forcing. ! #################################################################################### - function linterp_1D(this, var_name, year, month, day, hour, minute, second) result(err_message) + function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err_message) class(base_physics_process), intent(inout) :: this character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, minute, second + integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: err_message integer :: ti(1), tf(1) real(kind_phys) :: w1, w2 ! Interpolation weights - call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) + call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) select case(var_name) case("T") @@ -322,17 +335,17 @@ end function linterp_1D ! This assumes that the location dimension has a [longitude, latitude] associated with ! each location. ! #################################################################################### - function linterp_2D(this, var_name, lon, lat, year, month, day, hour, minute, second) result(err_message) + function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) result(err_message) class(base_physics_process), intent(inout) :: this character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, minute, second + integer, intent(in) :: year, month, day, hour, min, sec real(kind_phys), intent(in) :: lon, lat character(len=128) :: err_message integer :: ti(1), tf(1), iNearest real(kind_phys) :: w1, w2 ! Interpolation weights (temporal) - call this%cmp_time_wts(year, month, day, hour, minute, second, w1, w2, ti, tf) + call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) ! Grab data tendency closest to column [lon,lat] iNearest = this%find_nearest_loc_2d_1d(lon,lat) @@ -366,17 +379,17 @@ end function find_nearest_loc_2d_1d ! Type-bound procedure to compute linear interpolation weights for a diurnal (24-hour) ! forcing. ! #################################################################################### - subroutine cmp_time_wts(this, year, month, day, hour, minute, second, w1, w2, ti, tf) + subroutine cmp_time_wts(this, year, month, day, hour, minute, sec, w1, w2, ti, tf) ! Inputs class(base_physics_process), intent(in) :: this - integer, intent(in) :: year, month, day, hour, minute, second + integer, intent(in) :: year, month, day, hour, minute, sec ! Outputs integer,intent(out) :: ti(1), tf(1) real(kind_phys),intent(out) :: w1, w2 ! Locals real(kind_phys) :: hrofday - hrofday = hour*3600. + minute*60. + second + hrofday = hour*3600. + minute*60. + sec ti = max(hour,1) tf = min(ti + 1,24) w1 = ((hour+1)*3600 - hrofday)/3600 @@ -384,4 +397,123 @@ subroutine cmp_time_wts(this, year, month, day, hour, minute, second, w1, w2, ti end subroutine cmp_time_wts + ! #################################################################################### + subroutine sim_LWRAD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + + end subroutine sim_LWRAD + + ! #################################################################################### + subroutine sim_SWRAD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + + end subroutine sim_SWRAD + + ! #################################################################################### + subroutine sim_GWD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + + end subroutine sim_GWD + + ! #################################################################################### + subroutine sim_PBL( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_PBL + + ! #################################################################################### + subroutine sim_DCNV( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_DCNV + + ! #################################################################################### + subroutine sim_SCNV( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_SCNV + + ! #################################################################################### + subroutine sim_cldMP( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + end subroutine sim_cldMP + end module ccpp_scheme_simulator diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 index 8f4c7ee57..1fb3dc983 100644 --- a/physics/load_ccpp_scheme_sim.F90 +++ b/physics/load_ccpp_scheme_sim.F90 @@ -7,7 +7,7 @@ module load_ccpp_scheme_sim use machine, only: kind_phys use netcdf use ccpp_scheme_simulator, only: do_ccpp_scheme_simulator, physics_process, active_name,& - iactive_scheme, active_time_split_process + iactive_scheme, active_time_split_process, nactive_proc #ifdef MPI use mpi #endif @@ -73,7 +73,7 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file integer, intent(out) :: errflg ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc + integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc, iactive character(len=256) :: fileIN logical :: exists integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality @@ -540,13 +540,23 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file if (have_dTdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%T => dTdt_cldMP_data if (have_dqdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%q => dqdt_cldMP_data - ! Which process-scheme is "Active"? Is it a time-split process? + ! How many active schemes are there? + nactive_proc = 0 + iactive = 0 + do iprc = 1,nPhysProcess + if (.not. physics_process(iprc)%use_sim) nactive_proc = nactive_proc + 1 + enddo + allocate(iactive_scheme(nactive_proc),active_name(nactive_proc),active_time_split_process(nactive_proc)) + + ! Which process-scheme(s) is(are) "Active"? Are they time-split process? + active_time_split_process(:) = .false. do iprc = 1,nPhysProcess if (.not. physics_process(iprc)%use_sim) then - iactive_scheme = iprc - active_name = physics_process(iprc)%name + iactive = iactive + 1 + iactive_scheme(iactive) = iprc + active_name(iactive) = physics_process(iprc)%name if (physics_process(iprc)%time_split) then - active_time_split_process = .true. + active_time_split_process(iactive) = .true. endif endif enddo @@ -556,16 +566,19 @@ subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file print*, "-----------------------------------" print*, "--- Using CCPP scheme simulator ---" print*, "-----------------------------------" + iactive = 1 do iprc = 1,nPhysProcess if (physics_process(iprc)%use_sim) then print*," simulate_scheme: ", trim(physics_process(iprc)%name) print*," order: ", physics_process(iprc)%order print*," time_split: ", physics_process(iprc)%time_split + else + print*, " active_scheme: ", trim(active_name(iactive)) + print*, " order: ", physics_process(iactive_scheme(iactive))%order + print*, " time_split : ", active_time_split_process(iactive) + iactive = iactive + 1 endif enddo - print*, " active_scheme: ", trim(active_name) - print*, " order: ", physics_process(iactive_scheme)%order - print*, " time_split : ", active_time_split_process print*, "-----------------------------------" print*, "-----------------------------------" endif From 40e092d0d92d0c78848acc47ae83629908375a6c Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Thu, 23 Feb 2023 14:28:26 -0700 Subject: [PATCH 16/64] add runoff and drain to land coupling --- physics/sfc_land.f | 19 +++++++++++++++---- physics/sfc_land.meta | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 4 deletions(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index ab0691251..f7aebe171 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -37,9 +37,10 @@ subroutine sfc_land_run & & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & & ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & + & runoff_lnd, drain_lnd, ! --- outputs: & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & - & gflux, & + & gflux, runoff, drain, & & errmsg, errflg, naux2d, aux2d & ) @@ -54,9 +55,10 @@ subroutine sfc_land_run & ! ( im, cpllnd, cpllnd2atm, flag_iter, dry, ! ! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! ! ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, ! +! runoff_lnd, drain_lnd, ! ! outputs: ! ! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! -! gflux, ! +! gflux, runoff, drain, ! ! errmsg, errflg) ! ! ! ! ==================== defination of variables ==================== ! @@ -75,6 +77,8 @@ subroutine sfc_land_run & ! t2mmp_lnd - real , 2m temperature ! q2mp_lnd - real , 2m specific humidity ! gflux_lnd - real , soil heat flux over land +! runoff_lnd - real , surface runoff +! drain_lnd - real , subsurface runoff ! outputs: ! sncovr1 - real , snow cover over land ! qsurf - real , specific humidity at sfc @@ -84,6 +88,8 @@ subroutine sfc_land_run & ! t2mmp - real , temperature at 2m ! q2mp - real , specific humidity at 2m ! gflux - real , soil heat flux over land +! runoff - real , surface runoff +! drain - real , subsurface runoff ! ==================== end of description ===================== ! ! ! @@ -98,11 +104,12 @@ subroutine sfc_land_run & real (kind=kind_phys), dimension(:), intent(in) :: & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & - & t2mmp_lnd, q2mp_lnd, gflux_lnd + & t2mmp_lnd, q2mp_lnd, gflux_lnd, runoff_lnd, drain_lnd ! --- outputs: real (kind=kind_phys), dimension(:), intent(out) :: & - & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux + & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux, & + & runoff, drain ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -129,6 +136,8 @@ subroutine sfc_land_run & t2mmp(i) = t2mmp_lnd(i) q2mp(i) = q2mp_lnd(i) gflux(i) = gflux_lnd(i) + drain(i) = drain_lnd(i) + runoff(i) = runoff_lnd(i) enddo aux2d(:,1) = sncovr1(:) @@ -139,6 +148,8 @@ subroutine sfc_land_run & aux2d(:,6) = t2mmp(:) aux2d(:,7) = q2mp(:) aux2d(:,8) = gflux(:) + aux2d(:,9) = drain(:) + aux2d(:,10) = runoff(:) return !----------------------------------- diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index 50ddecd46..60a853b89 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -106,6 +106,22 @@ type = real kind = kind_phys intent = in +[runoff_lnd] + standard_name = surface_runoff_flux_from_land + long_name = surface runoff flux over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[drain_lnd] + standard_name = subsurface_runoff_flux_from_land + long_name = subsurface runoff flux over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [sncovr1] standard_name = surface_snow_area_fraction_over_land long_name = surface snow area fraction @@ -170,6 +186,22 @@ type = real kind = kind_phys intent = out +[runoff] + standard_name = surface_runoff_flux + long_name = surface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[drain] + standard_name = subsurface_runoff_flux + long_name = subsurface runoff flux + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 64fdd5aa53672132bf1295701a9d7844232f336b Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Tue, 7 Mar 2023 11:00:00 -0700 Subject: [PATCH 17/64] add exchange coefficents --- physics/sfc_land.f | 23 ++++++++++++++++------- physics/sfc_land.meta | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 48 insertions(+), 7 deletions(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index f7aebe171..0436519a5 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -37,10 +37,10 @@ subroutine sfc_land_run & & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & & ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & - & runoff_lnd, drain_lnd, + & runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, ! --- outputs: & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & - & gflux, runoff, drain, & + & gflux, runoff, drain, cmm, chh, & & errmsg, errflg, naux2d, aux2d & ) @@ -55,10 +55,10 @@ subroutine sfc_land_run & ! ( im, cpllnd, cpllnd2atm, flag_iter, dry, ! ! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! ! ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, ! -! runoff_lnd, drain_lnd, ! +! runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, ! ! outputs: ! ! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! -! gflux, runoff, drain, ! +! gflux, runoff, drain, cmm, chh, ! ! errmsg, errflg) ! ! ! ! ==================== defination of variables ==================== ! @@ -79,6 +79,8 @@ subroutine sfc_land_run & ! gflux_lnd - real , soil heat flux over land ! runoff_lnd - real , surface runoff ! drain_lnd - real , subsurface runoff +! cmm_lnd - real , surface drag wind speed for momentum +! chh_lnd - real , surface drag mass flux for heat and moisture ! outputs: ! sncovr1 - real , snow cover over land ! qsurf - real , specific humidity at sfc @@ -89,7 +91,9 @@ subroutine sfc_land_run & ! q2mp - real , specific humidity at 2m ! gflux - real , soil heat flux over land ! runoff - real , surface runoff -! drain - real , subsurface runoff +! drain - real , subsurface runoff +! cmm - real , surface drag wind speed for momentum +! chh - real , surface drag mass flux for heat and moisture ! ==================== end of description ===================== ! ! ! @@ -104,12 +108,13 @@ subroutine sfc_land_run & real (kind=kind_phys), dimension(:), intent(in) :: & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & - & t2mmp_lnd, q2mp_lnd, gflux_lnd, runoff_lnd, drain_lnd + & t2mmp_lnd, q2mp_lnd, gflux_lnd, runoff_lnd, drain_lnd, & + & cmm_lnd, chh_lnd ! --- outputs: real (kind=kind_phys), dimension(:), intent(out) :: & & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux, & - & runoff, drain + & runoff, drain, cmm, chh ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -138,6 +143,8 @@ subroutine sfc_land_run & gflux(i) = gflux_lnd(i) drain(i) = drain_lnd(i) runoff(i) = runoff_lnd(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) enddo aux2d(:,1) = sncovr1(:) @@ -150,6 +157,8 @@ subroutine sfc_land_run & aux2d(:,8) = gflux(:) aux2d(:,9) = drain(:) aux2d(:,10) = runoff(:) + aux2d(:,11) = cmm(:) + aux2d(:,12) = chh(:) return !----------------------------------- diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index 60a853b89..99a795c65 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -122,6 +122,22 @@ type = real kind = kind_phys intent = in +[cmm_lnd] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land_from_land + long_name = momentum exchange coefficient over land for coupling + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[chh_lnd] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land_from_land + long_name = thermal exchange coefficient over land for coupling + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [sncovr1] standard_name = surface_snow_area_fraction_over_land long_name = surface snow area fraction @@ -202,6 +218,22 @@ type = real kind = kind_phys intent = out +[cmm] + standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land + long_name = momentum exchange coefficient over land + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[chh] + standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land + long_name = thermal exchange coefficient over land + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 91a9b44eac42dfaf047cfc79718fa0332db0979d Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Tue, 7 Mar 2023 22:40:41 -0700 Subject: [PATCH 18/64] add zvfun to land coupling --- physics/sfc_land.f | 15 ++++++++++----- physics/sfc_land.meta | 16 ++++++++++++++++ 2 files changed, 26 insertions(+), 5 deletions(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index 0436519a5..44a9b5a06 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -37,10 +37,10 @@ subroutine sfc_land_run & & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & & ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & - & runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, + & runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, zvfun_lnd, & ! --- outputs: & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & - & gflux, runoff, drain, cmm, chh, & + & gflux, runoff, drain, cmm, chh, zvfun, & & errmsg, errflg, naux2d, aux2d & ) @@ -56,9 +56,10 @@ subroutine sfc_land_run & ! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! ! ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, ! ! runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, ! +! zvfun_lnd, ! ! outputs: ! ! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! -! gflux, runoff, drain, cmm, chh, ! +! gflux, runoff, drain, cmm, chh, zvfun, ! ! errmsg, errflg) ! ! ! ! ==================== defination of variables ==================== ! @@ -81,6 +82,7 @@ subroutine sfc_land_run & ! drain_lnd - real , subsurface runoff ! cmm_lnd - real , surface drag wind speed for momentum ! chh_lnd - real , surface drag mass flux for heat and moisture +! zvfun_lnd - real , function of surface roughness length and green vegetation fraction ! outputs: ! sncovr1 - real , snow cover over land ! qsurf - real , specific humidity at sfc @@ -94,6 +96,7 @@ subroutine sfc_land_run & ! drain - real , subsurface runoff ! cmm - real , surface drag wind speed for momentum ! chh - real , surface drag mass flux for heat and moisture +! zvfun - real , function of surface roughness length and green vegetation fraction ! ==================== end of description ===================== ! ! ! @@ -109,12 +112,12 @@ subroutine sfc_land_run & real (kind=kind_phys), dimension(:), intent(in) :: & & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & & t2mmp_lnd, q2mp_lnd, gflux_lnd, runoff_lnd, drain_lnd, & - & cmm_lnd, chh_lnd + & cmm_lnd, chh_lnd, zvfun_lnd ! --- outputs: real (kind=kind_phys), dimension(:), intent(out) :: & & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux, & - & runoff, drain, cmm, chh + & runoff, drain, cmm, chh, zvfun ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -145,6 +148,7 @@ subroutine sfc_land_run & runoff(i) = runoff_lnd(i) cmm(i) = cmm_lnd(i) chh(i) = chh_lnd(i) + zvfun(i) = zvfun_lnd(i) enddo aux2d(:,1) = sncovr1(:) @@ -159,6 +163,7 @@ subroutine sfc_land_run & aux2d(:,10) = runoff(:) aux2d(:,11) = cmm(:) aux2d(:,12) = chh(:) + aux2d(:,13) = zvfun(:) return !----------------------------------- diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index 99a795c65..a146dec3a 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -138,6 +138,14 @@ type = real kind = kind_phys intent = in +[zvfun_lnd] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction_from_land + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [sncovr1] standard_name = surface_snow_area_fraction_over_land long_name = surface snow area fraction @@ -234,6 +242,14 @@ type = real kind = kind_phys intent = out +[zvfun] + standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction + long_name = function of surface roughness length and green vegetation fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 8442a202769b4082d548c4d0d0b5d0c1cb7a80c1 Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Wed, 5 Apr 2023 15:49:56 -0600 Subject: [PATCH 19/64] clean sfc_land --- physics/sfc_land.f | 22 +--------------------- physics/sfc_land.meta | 15 --------------- 2 files changed, 1 insertion(+), 36 deletions(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index 44a9b5a06..aec47ff77 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -27,9 +27,6 @@ module sfc_land !! \section detailed Detailed Algorithm !! @{ - -!! use physcons, only : hvap => con_hvap, cp => con_cp, & -!! & rvrdm1 => con_fvirt, rd => con_rd ! !----------------------------------- subroutine sfc_land_run & @@ -41,7 +38,7 @@ subroutine sfc_land_run & ! --- outputs: & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & & gflux, runoff, drain, cmm, chh, zvfun, & - & errmsg, errflg, naux2d, aux2d + & errmsg, errflg & ) ! ===================================================================== ! @@ -122,9 +119,6 @@ subroutine sfc_land_run & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - integer, intent(in) :: naux2d - real(kind_phys), intent(out) :: aux2d(:,:) - ! --- locals: integer :: i @@ -150,20 +144,6 @@ subroutine sfc_land_run & chh(i) = chh_lnd(i) zvfun(i) = zvfun_lnd(i) enddo - - aux2d(:,1) = sncovr1(:) - aux2d(:,2) = qsurf(:) - aux2d(:,3) = hflx(:) - aux2d(:,4) = evap(:) - aux2d(:,5) = ep(:) - aux2d(:,6) = t2mmp(:) - aux2d(:,7) = q2mp(:) - aux2d(:,8) = gflux(:) - aux2d(:,9) = drain(:) - aux2d(:,10) = runoff(:) - aux2d(:,11) = cmm(:) - aux2d(:,12) = chh(:) - aux2d(:,13) = zvfun(:) return !----------------------------------- diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index a146dec3a..979cca377 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -265,18 +265,3 @@ dimensions = () type = integer intent = out -[naux2d] - standard_name = number_of_xy_dimensioned_auxiliary_arrays - long_name = number of 2d auxiliary arrays to output (for debugging) - units = count - dimensions = () - type = integer - intent = in -[aux2d] - standard_name = auxiliary_2d_arrays - long_name = auxiliary 2d arrays to output (for debugging) - units = none - dimensions = (horizontal_loop_extent,number_of_xy_dimensioned_auxiliary_arrays) - type = real - kind = kind_phys - intent = out From a3933a549c7ced2ae9f9c7b30b42090cfa2134ca Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 4 May 2023 11:20:02 -0600 Subject: [PATCH 20/64] CCPP scheme simulator --- physics/GFS_ccpp_scheme_sim_pre.F90 | 603 ++++++++++++++++++++++ physics/GFS_ccpp_scheme_sim_pre.meta | 295 +++++++++++ physics/ccpp_scheme_simulator.F90 | 450 +++------------- physics/ccpp_scheme_simulator.meta | 187 +++---- physics/module_ccpp_scheme_simulator.F90 | 302 +++++++++++ physics/module_ccpp_scheme_simulator.meta | 24 + 6 files changed, 1382 insertions(+), 479 deletions(-) create mode 100644 physics/GFS_ccpp_scheme_sim_pre.F90 create mode 100644 physics/GFS_ccpp_scheme_sim_pre.meta create mode 100644 physics/module_ccpp_scheme_simulator.F90 create mode 100644 physics/module_ccpp_scheme_simulator.meta diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 new file mode 100644 index 000000000..acd0c6692 --- /dev/null +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -0,0 +1,603 @@ +! ######################################################################################## +! +! Interstitial CCPP scheme to couple UFS physics to ccpp_scheme_simulator. +! ) _init: read and load data into type used by ccpp_scheme_simulator +! ) _run: prepare GFS diagnostic physics tendencies for ccpp_scheme_simulator +! +! ######################################################################################## +module GFS_ccpp_scheme_sim_pre + use machine, only: kind_phys + use netcdf + use module_ccpp_scheme_simulator, only: base_physics_process +#ifdef MPI + use mpi +#endif + implicit none + + public GFS_ccpp_scheme_sim_pre_init, GFS_ccpp_scheme_sim_pre_run +contains + + ! ###################################################################################### + ! + ! SUBROUTINE GFS_ccpp_scheme_sim_pre_init + ! + ! ###################################################################################### +!! \section arg_table_GFS_ccpp_scheme_sim_pre_init +!! \htmlinclude GFS_ccpp_scheme_sim_pre_init.html +!! + subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_scheme_sim, & + scheme_sim_data, nprg_active, nprc_sim, prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg,& + prc_GWD_cfg, prc_SCNV_cfg, prc_DCNV_cfg, prc_cldMP_cfg, active_name, & + iactive_scheme, active_time_split_process, physics_process, errmsg, errflg) + + ! Inputs + integer, intent (in) :: mpirank, mpiroot, mpicomm, nprg_active, nprc_sim + logical, intent (in) :: do_ccpp_scheme_sim + character(len=256), intent (in) :: scheme_sim_data + integer, dimension(3), intent (in) :: prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, & + prc_GWD_cfg, prc_SCNV_cfg, prc_DCNV_cfg, prc_cldMP_cfg + + ! Outputs + type(base_physics_process),intent(inout) :: physics_process(:) + character(len=16),intent(inout) :: active_name(:) + integer, intent(inout) :: iactive_scheme(:) + logical, intent(inout) :: active_time_split_process(:) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Local variables + integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc, iactive + logical :: exists + + ! Switches for input data + logical :: have_dTdt_LWRAD_data = .false., & + have_dTdt_SWRAD_data = .false., & + have_dTdt_PBL_data = .false., & + have_dqdt_PBL_data = .false., & + have_dudt_PBL_data = .false., & + have_dvdt_PBL_data = .false., & + have_dTdt_GWD_data = .false., & + have_dudt_GWD_data = .false., & + have_dvdt_GWD_data = .false., & + have_dTdt_SCNV_data = .false., & + have_dudt_SCNV_data = .false., & + have_dvdt_SCNV_data = .false., & + have_dqdt_SCNV_data = .false., & + have_dTdt_DCNV_data = .false., & + have_dudt_DCNV_data = .false., & + have_dvdt_DCNV_data = .false., & + have_dqdt_DCNV_data = .false., & + have_dTdt_cldMP_data = .false., & + have_dqdt_cldMP_data = .false. + + ! Data driven physics tendencies + integer :: nlev_data, ntime_data + real(kind_phys), allocatable, dimension(:), target :: time_data + real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & + dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & + dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & + dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data + real(kind_phys), allocatable, dimension(:,:), target :: dqdt_PBL_data, & + dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not. do_ccpp_scheme_sim) return + + ! ###################################################################################### + ! + ! Part A) Read in data. + ! + ! ###################################################################################### + + ! Check that input data file exists + inquire (file = trim (scheme_sim_data), exist = exists) + if (.not. exists) then + errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not exist' + errflg = 1 + return + endif + + ! Read mandatory information from data file... + ! (ONLY master processor(0), if MPI enabled) +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Open file (required) + status = nf90_open(trim(scheme_sim_data), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + errmsg = 'Error reading in SCM data tendency file: '//trim(scheme_sim_data) + errflg = 1 + return + endif + + ! Get dimensions (required) + status = nf90_inq_dimid(ncid, 'time', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) + else + errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain [time] dimension' + errflg = 1 + return + endif + ! + status = nf90_inq_dimid(ncid, 'lev', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) + else + errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain [lev] dimension' + errflg = 1 + return + endif +#ifdef MPI + endif ! On master processor + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! Broadcast dimensions... + ! (ALL processors) + call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) + call mpi_barrier(mpicomm, mpierr) + + if (mpirank .eq. mpiroot) then +#endif + + ! + ! What data fields do we have? + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) have_dTdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) have_dqdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) have_dudt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) have_dvdt_PBL_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) have_dTdt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) have_dudt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) have_dvdt_GWD_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) have_dTdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) have_dudt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) have_dvdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) have_dqdt_SCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) have_dTdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) have_dudt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) have_dvdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) have_dqdt_DCNV_data = .true. + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) have_dTdt_cldMP_data = .true. + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) have_dqdt_cldMP_data = .true. + +#ifdef MPI + endif ! Master process +#endif + + ! Allocate space for data + allocate(time_data(ntime_data)) + if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) + if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) + if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data)) + if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) + if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) + if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) + if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) + if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) + if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) + if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) + if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) + if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data)) + if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) + if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) + if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) + if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data)) + if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) + if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data)) + + ! Read in data ... + ! (ONLY master processor(0), if MPI enabled) +#ifdef MPI + if (mpirank .eq. mpiroot) then +#endif + + ! Temporal info (required) + status = nf90_inq_varid(ncid, 'times', varID) + if (status == nf90_noerr) then + status = nf90_get_var( ncid, varID, time_data) + else + errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain times variable' + errflg = 1 + return + endif + + ! Read in physics data tendencies (optional) + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) + ! + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) + ! + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) + ! + status = nf90_close(ncid) + +#ifdef MPI + endif ! Master process + + ! Other processors waiting... + call mpi_barrier(mpicomm, mpierr) + + ! Broadcast data... + ! (ALL processors) + if (have_dTdt_LWRAD_data) then + call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_SWRAD_data) then + call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_PBL_data) then + call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_PBL_data) then + call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_PBL_data) then + call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_PBL_data) then + call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_GWD_data) then + call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_GWD_data) then + call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_GWD_data) then + call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_SCNV_data) then + call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_SCNV_data) then + call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_SCNV_data) then + call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_SCNV_data) then + call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_DCNV_data) then + call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dudt_DCNV_data) then + call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dvdt_DCNV_data) then + call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_DCNV_data) then + call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dTdt_cldMP_data) then + call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + if (have_dqdt_cldMP_data) then + call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) + endif + ! + call mpi_barrier(mpicomm, mpierr) +#endif + + ! ####################################################################################### + ! + ! Part B) Populate physics_process type. + ! + ! ####################################################################################### + + ! Metadata + do iprc = 1,nprc_sim + if (iprc == prc_SWRAD_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SWRAD" + if (prc_SWRAD_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_SWRAD_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_LWRAD_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "LWRAD" + if (prc_LWRAD_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_LWRAD_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_GWD_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "GWD" + if (prc_GWD_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_GWD_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_PBL_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "PBL" + if (prc_PBL_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_PBL_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_SCNV_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "SCNV" + if (prc_SCNV_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_SCNV_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_DCNV_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "DCNV" + if (prc_DCNV_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_DCNV_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + if (iprc == prc_cldMP_cfg(3)) then + physics_process(iprc)%order = iprc + physics_process(iprc)%name = "cldMP" + if (prc_cldMP_cfg(1) == 1) then + physics_process(iprc)%use_sim = .true. + endif + if (prc_cldMP_cfg(2) == 1) then + physics_process(iprc)%time_split = .true. + endif + endif + enddo + + ! Load data + physics_process(prc_LWRAD_cfg(3))%tend2d%time => time_data + physics_process(prc_SWRAD_cfg(3))%tend2d%time => time_data + physics_process(prc_PBL_cfg(3))%tend2d%time => time_data + physics_process(prc_GWD_cfg(3))%tend2d%time => time_data + physics_process(prc_DCNV_cfg(3))%tend2d%time => time_data + physics_process(prc_SCNV_cfg(3))%tend2d%time => time_data + physics_process(prc_cldMP_cfg(3))%tend2d%time => time_data + if (have_dTdt_LWRAD_data) physics_process(prc_SWRAD_cfg(3))%tend2d%T => dTdt_LWRAD_data + if (have_dTdt_SWRAD_data) physics_process(prc_LWRAD_cfg(3))%tend2d%T => dTdt_SWRAD_data + if (have_dTdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%T => dTdt_PBL_data + if (have_dudt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%u => dudt_PBL_data + if (have_dvdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%v => dvdt_PBL_data + if (have_dqdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%q => dqdt_PBL_data + if (have_dTdt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%T => dTdt_GWD_data + if (have_dudt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%u => dudt_GWD_data + if (have_dvdt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%v => dvdt_GWD_data + if (have_dTdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%T => dTdt_SCNV_data + if (have_dudt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%u => dudt_SCNV_data + if (have_dvdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%v => dvdt_SCNV_data + if (have_dqdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%q => dqdt_SCNV_data + if (have_dTdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%T => dTdt_DCNV_data + if (have_dudt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%u => dudt_DCNV_data + if (have_dvdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%v => dvdt_DCNV_data + if (have_dqdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%q => dqdt_DCNV_data + if (have_dTdt_cldMP_data) physics_process(prc_cldMP_cfg(3))%tend2d%T => dTdt_cldMP_data + if (have_dqdt_cldMP_data) physics_process(prc_cldMP_cfg(3))%tend2d%q => dqdt_cldMP_data + + ! Which process-scheme(s) is(are) "Active"? Are they time-split process? + iactive = 0 + active_time_split_process(:) = .false. + do iprc = 1,nprc_sim + if (.not. physics_process(iprc)%use_sim) then + iactive = iactive + 1 + iactive_scheme(iactive) = iprc + active_name(iactive) = physics_process(iprc)%name + if (physics_process(iprc)%time_split) then + active_time_split_process(iactive) = .true. + endif + endif + enddo + + ! + if (mpirank .eq. mpiroot) then + print*, "-----------------------------------" + print*, "--- Using CCPP scheme simulator ---" + print*, "-----------------------------------" + iactive = 1 + do iprc = 1,nprc_sim + if (physics_process(iprc)%use_sim) then + print*," simulate_scheme: ", trim(physics_process(iprc)%name) + print*," order: ", physics_process(iprc)%order + print*," time_split: ", physics_process(iprc)%time_split + else + print*, " active_scheme: ", trim(active_name(iactive)) + print*, " order: ", physics_process(iactive_scheme(iactive))%order + print*, " time_split : ", active_time_split_process(iactive) + iactive = iactive + 1 + endif + enddo + print*, "-----------------------------------" + print*, "-----------------------------------" + endif + + end subroutine GFS_ccpp_scheme_sim_pre_init + + ! ###################################################################################### + ! + ! SUBROUTINE GFS_ccpp_scheme_sim_pre_run + ! + ! ###################################################################################### +!! \section arg_table_GFS_ccpp_scheme_sim_pre_run +!! \htmlinclude GFS_ccpp_scheme_sim_pre_run.html +!! + subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process_dcnv, & + index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind, & + active_name, iactive_scheme_inloop, active_phys_tend, errmsg, errflg) + + ! Inputs + integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & + index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind, iactive_scheme_inloop + integer, intent(in), dimension(:,:) :: dtidx + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in), dimension(:,:,:) :: dtend + character(len=16),intent(in), dimension(:) :: active_name + + ! Outputs + real(kind_phys), intent(out) :: active_phys_tend(:,:,:) + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Locals + integer :: idtend, iactive + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Get tendency for "active" process. + + ! ###################################################################################### + ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional + ! array, CCPP standard_name = cumulative_change_of_state_variables. + ! These are not the instantaneous physics tendencies that are applied to the state by + ! the physics schemes. Not all schemes output physics tendencies... + ! Rather these are intended for diagnostic puposes and are accumulated over some + ! interval. + ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option + ! "fhzero". For this to work, you need to clear the diagnostic buckets after each + ! physics timestep when running in the UFS/SCM. + ! + ! In the SCM this is done by adding the following runtime options: + ! --n_itt_out 1 --n_itt_diag 1 + ! + ! ###################################################################################### + if (active_name(iactive_scheme_inloop) == "LWRAD") iactive = index_of_process_longwave + if (active_name(iactive_scheme_inloop) == "SWRAD") iactive = index_of_process_shortwave + if (active_name(iactive_scheme_inloop) == "PBL") iactive = index_of_process_pbl + if (active_name(iactive_scheme_inloop) == "GWD") iactive = index_of_process_orographic_gwd + if (active_name(iactive_scheme_inloop) == "SCNV") iactive = index_of_process_scnv + if (active_name(iactive_scheme_inloop) == "DCNV") iactive = index_of_process_dcnv + if (active_name(iactive_scheme_inloop) == "cldMP") iactive = index_of_process_mp + + ! Heat + idtend = dtidx(index_of_temperature,iactive) + if (idtend >= 1) active_phys_tend(:,:,1) = dtend(:,:,idtend)/dtp + ! u-wind + idtend = dtidx(index_of_x_wind,iactive) + if (idtend >= 1) active_phys_tend(:,:,2) = dtend(:,:,idtend)/dtp + ! v-wind + idtend = dtidx(index_of_y_wind,iactive) + if (idtend >= 1) active_phys_tend(:,:,3) = dtend(:,:,idtend)/dtp + ! Moisture + idtend = dtidx(100+ntqv,iactive) + if (idtend >= 1) active_phys_tend(:,:,4) = dtend(:,:,idtend)/dtp + + + end subroutine GFS_ccpp_scheme_sim_pre_run + +end module GFS_ccpp_scheme_sim_pre diff --git a/physics/GFS_ccpp_scheme_sim_pre.meta b/physics/GFS_ccpp_scheme_sim_pre.meta new file mode 100644 index 000000000..cf7678fe6 --- /dev/null +++ b/physics/GFS_ccpp_scheme_sim_pre.meta @@ -0,0 +1,295 @@ +[ccpp-table-properties] + name = GFS_ccpp_scheme_sim_pre + type = scheme + dependencies = machine.F,module_ccpp_scheme_simulator.F90 + +######################################################################## +[ccpp-arg-table] + name = GFS_ccpp_scheme_sim_pre_init + type = scheme +[mpirank] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[prc_LWRAD_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_LWRAD + long_name = configuration for physics process in CCPP scheme simulator LWRAD + units = flag + dimensions = (3) + type = integer + intent = in +[prc_SWRAD_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_SWRAD + long_name = configuration for physics process in CCPP scheme simulator SWRAD + units = flag + dimensions = (3) + type = integer + intent = in +[prc_PBL_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_PBL + long_name = configuration for physics process in CCPP scheme simulator PBL + units = flag + dimensions = (3) + type = integer + intent = in +[prc_GWD_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_GWD + long_name = configuration for physics process in CCPP scheme simulator GWD + units = flag + dimensions = (3) + type = integer + intent = in +[prc_SCNV_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_SCNV + long_name = configuration for physics process in CCPP scheme simulator SCNV + units = flag + dimensions = (3) + type = integer + intent = in +[prc_DCNV_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_DCNV + long_name = configuration for physics process in CCPP scheme simulator DCNV + units = flag + dimensions = (3) + type = integer + intent = in +[prc_cldMP_cfg] + standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_cldMP + long_name = configuration for physics process in CCPP scheme simulator cldMP + units = flag + dimensions = (3) + type = integer + intent = in +[nprg_active] + standard_name = number_of_prognostics_varaibles_in_CCPP_scheme_simulator + long_name = number of prognostic variables used in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[do_ccpp_scheme_sim] + standard_name = flag_for_ccpp_scheme_simulator + long_name = flag for ccpp scheme simulator + units = flag + dimensions = () + type = logical + intent = in +[scheme_sim_data] + standard_name = filename_for_ccpp_scheme_simulator_data_file + long_name = filename for cccpp scheme simulator data file + units = none + dimensions = () + type = character + kind = len=256 + intent = in +[nprc_sim] + standard_name = number_of_physics_process_in_CCPP_scheme_simulator + long_name = number of physics process in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[active_name] + standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator + long_name = name of active physics schemes in CCPP scheme simulator + units = + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = character + kind = len=16 + intent = inout +[iactive_scheme] + standard_name = index_of_active_physics_schemes_in_CCPP_scheme_simulator + long_name = index of active physics schemes in CCPP scheme simulator + units = count + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = integer + intent = inout +[active_time_split_process] + standard_name = flag_to_indicate_process_type_in_CCPP_scheme_simulator + long_name = flag to indicate if active physics schemes are time-split process + units = flag + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = logical + intent = inout +[physics_process] + standard_name = physics_process_type_for_CCPP_scheme_simulator + long_name = physics process type for CCPP scheme simulator + units = mixed + dimensions = (number_of_physics_process_in_CCPP_scheme_simulator) + type = base_physics_process + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = GFS_ccpp_scheme_sim_pre_run + type = scheme +[iactive_scheme_inloop] + standard_name = count_for_active_scheme_in_CCPP_scheme_simulator + long_name = count for active physics scheme in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[active_name] + standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator + long_name = name of active physics schemes in CCPP scheme simulator + units = + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = character + kind = len=16 + intent = in +[dtend] + standard_name = cumulative_change_of_state_variables + long_name = diagnostic tendencies for state variables + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + type = real + kind = kind_phys + intent = in +[dtidx] + standard_name = cumulative_change_of_state_variables_outer_index + long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index + units = index + dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[index_of_process_dcnv] + standard_name = index_of_deep_convection_process_process_in_cumulative_change_index + long_name = index of deep convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_longwave] + standard_name = index_of_longwave_heating_process_in_cumulative_change_index + long_name = index of longwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_shortwave] + standard_name = index_of_shortwave_heating_process_in_cumulative_change_index + long_name = index of shortwave heating process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_orographic_gwd] + standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index + long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_scnv] + standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index + long_name = index of shallow convection process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_pbl] + standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index + long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_process_mp] + standard_name = index_of_microphysics_process_process_in_cumulative_change_index + long_name = index of microphysics transport process in second dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_temperature] + standard_name = index_of_temperature_in_cumulative_change_index + long_name = index of temperature in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_x_wind] + standard_name = index_of_x_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[index_of_y_wind] + standard_name = index_of_y_wind_in_cumulative_change_index + long_name = index of x-wind in first dimension of array cumulative change index + units = index + dimensions = () + type = integer + intent = in +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water vapor (specific humidity) + units = index + dimensions = () + type = integer + intent = in +[active_phys_tend] + standard_name = tendencies_for_active_process_in_ccpp_scheme_simulator + long_name = tendencies for active physics process in ccpp scheme simulator + units = mixed + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_scheme_simulator) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out \ No newline at end of file diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index f75580fb9..21f7bfde9 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -7,93 +7,10 @@ ! ######################################################################################## module ccpp_scheme_simulator use machine, only: kind_phys - + use module_ccpp_scheme_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & + sim_PBL, sim_GWD, sim_DCNV, sim_SCNV, sim_cldMP implicit none - - ! ######################################################################################## - ! Types used by the scheme simulator - ! ######################################################################################## - ! Type containing 1D (time) physics tendencies. - type phys_tend_1d - real(kind_phys), dimension(:), pointer :: T - real(kind_phys), dimension(:), pointer :: u - real(kind_phys), dimension(:), pointer :: v - real(kind_phys), dimension(:), pointer :: q - end type phys_tend_1d - - ! Type containing 2D (lev,time) physics tendencies. - type phys_tend_2d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: T - real(kind_phys), dimension(:,:), pointer :: u - real(kind_phys), dimension(:,:), pointer :: v - real(kind_phys), dimension(:,:), pointer :: q - end type phys_tend_2d - - ! Type containing 3D (loc,lev,time) physics tendencies. - type phys_tend_3d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:), pointer :: lon - real(kind_phys), dimension(:), pointer :: lat - real(kind_phys), dimension(:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:), pointer :: q - end type phys_tend_3d - - ! Type containing 4D (lon, lat,lev,time) physics tendencies. - type phys_tend_4d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: lon - real(kind_phys), dimension(:,:), pointer :: lat - real(kind_phys), dimension(:,:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:,:), pointer :: q - end type phys_tend_4d - - ! This type contains the meta information and data for each physics process. - type base_physics_process - character(len=16) :: name - logical :: time_split = .false. - logical :: use_sim = .false. - integer :: order - type(phys_tend_1d) :: tend1d - type(phys_tend_2d) :: tend2d - type(phys_tend_3d) :: tend3d - type(phys_tend_4d) :: tend4d - contains - generic, public :: linterp => linterp_1D, linterp_2D - procedure, private :: linterp_1D - procedure, private :: linterp_2D - procedure, public :: find_nearest_loc_2d_1d - procedure, public :: cmp_time_wts - end type base_physics_process - - ! This array contains the governing information on how to advance the physics timestep. - type(base_physics_process), dimension(:), allocatable :: & - physics_process - - ! Do not change these! - ! For time-split physics process we need to call this scheme twice in the SDF, once - ! before the "active" scheme is called, and once after. This is because the active - ! scheme uses an internal physics state that has been advanced forward by a subsequent - ! physics process(es). - integer :: nactive_proc - character(len=16),allocatable,dimension(:) :: active_name - integer,allocatable,dimension(:) :: iactive_scheme - logical,allocatable,dimension(:) :: active_time_split_process - integer :: iactive_scheme_inloop = 1 - - integer :: proc_start, proc_end - logical :: in_pre_active = .true. - logical :: in_post_active = .false. - - ! Set to true in data was loaded into "physics_process" - logical :: do_ccpp_scheme_simulator=.false. - public ccpp_scheme_simulator_run - contains ! ###################################################################################### @@ -104,42 +21,38 @@ module ccpp_scheme_simulator !! \section arg_table_ccpp_scheme_simulator_run !! \htmlinclude ccpp_scheme_simulator_run.html !! - subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dtidx, & - dtend, index_of_process_dcnv, index_of_process_longwave, & - index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, ntqv, gt0, gu0, gv0, gq0, & - dtdq_pbl, dtdq_mp, errmsg, errflg) + subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, jdat, & + nactive_proc, proc_start, proc_end, active_name, iactive_scheme, physics_process, & + active_time_split_process, iactive_scheme_inloop, in_pre_active, in_post_active, & + tgrs, ugrs, vgrs, qgrs, active_phys_tend, gt0, gu0, gv0, gq0, dtdq_pbl, dtdq_mp, & + errmsg, errflg) ! Inputs - integer, intent(in) :: kdt, ntqv, index_of_process_dcnv, & - index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind - integer, intent(in), dimension(8) :: jdat - integer, intent(in), dimension(:,:) :: dtidx - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in), dimension(:,:) :: tgrs, ugrs, vgrs - real(kind_phys), intent(in), dimension(:,:,:) :: qgrs, dtend + logical, intent(in) :: do_ccpp_scheme_sim, active_time_split_process(:) + integer, intent(in) :: kdt, nCol, nLay, nactive_proc, jdat(8), & + iactive_scheme(:) + real(kind_phys), intent(in) :: dtp, tgrs(:,:), ugrs(:,:), vgrs(:,:), qgrs(:,:,:), & + active_phys_tend(:,:,:) + character(len=16), intent(in) :: active_name(:) ! Outputs - real(kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 - real(kind_phys), intent(inout), dimension(:,:) :: gq0, dtdq_pbl, dtdq_mp - character(len=*),intent(out) :: errmsg - integer, intent(out) :: errflg + type(base_physics_process),intent(inout) :: physics_process(:) + real(kind_phys), intent(inout) :: gt0(:,:), gu0(:,:), gv0(:,:), gq0(:,:), & + dtdq_pbl(:,:), dtdq_mp(:,:) + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg + integer, intent(inout) :: proc_start, proc_end, iactive_scheme_inloop + logical, intent(inout) :: in_pre_active, in_post_active ! Locals - integer :: iCol, iLay, nCol, nLay, idtend, year, month, day, hour, min, sec, iprc, & - index_of_active_process - real(kind_phys) :: w1, w2,hrofday - real(kind_phys), dimension(:,:), allocatable :: gt1, gu1, gv1, dTdt, dudt, dvdt - real(kind_phys), dimension(:,:), allocatable :: gq1, dqdt + integer :: iCol, year, month, day, hour, min, sec, iprc + real(kind_phys), dimension(nCol,nLay) :: gt1, gu1, gv1, dTdt, dudt, dvdt, gq1, dqdt ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - if (.not. do_ccpp_scheme_simulator) return + if (.not. do_ccpp_scheme_sim) return ! Current forecast time (Data-format specific) year = jdat(1) @@ -149,34 +62,6 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti min = jdat(6) sec = jdat(7) - ! Dimensions - nCol = size(gq0(:,1)) - nLay = size(gq0(1,:)) - - ! Allocate temporaries - allocate(gt1(nCol,nLay), gu1(nCol,nLay), gv1(nCol,nLay), gq1(nCol,nLay)) - allocate(dTdt(nCol,nLay), dudt(nCol,nLay), dvdt(nCol,nLay), dqdt(nCol,nLay)) - - ! Get tendency for "active" process. - ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional - ! array, CCPP standard_name = cumulative_change_of_state_variables. - ! These are not the instantaneous physics tendencies that are applied to the state by the - ! physics schemes. Not all schemes output physics tendencies... - ! Rather these are intended for diagnostic puposes and are accumulated over some interval. - ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option "fhzero". - ! For this to work, you need to clear the diagnostic buckets after each physics timestep when - ! running in the UFS/SCM. - ! In the SCM this is done by adding the following runtime options: - ! --n_itt_out 1 --n_itt_diag 1 - ! - if (active_name(iactive_scheme_inloop) == "LWRAD") index_of_active_process = index_of_process_longwave - if (active_name(iactive_scheme_inloop) == "SWRAD") index_of_active_process = index_of_process_shortwave - if (active_name(iactive_scheme_inloop) == "PBL") index_of_active_process = index_of_process_pbl - if (active_name(iactive_scheme_inloop) == "GWD") index_of_active_process = index_of_process_orographic_gwd - if (active_name(iactive_scheme_inloop) == "SCNV") index_of_active_process = index_of_process_scnv - if (active_name(iactive_scheme_inloop) == "DCNV") index_of_active_process = index_of_process_dcnv - if (active_name(iactive_scheme_inloop) == "cldMP") index_of_active_process = index_of_process_mp - ! Set state at beginning of the physics timestep. gt1(:,:) = tgrs(:,:) gu1(:,:) = ugrs(:,:) @@ -187,6 +72,9 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dvdt(:,:) = 0. dqdt(:,:) = 0. + ! + ! Set bookeeping indices + ! if (in_pre_active) then proc_start = 1 proc_end = max(1,iactive_scheme(iactive_scheme_inloop)-1) @@ -196,22 +84,27 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti proc_end = size(physics_process) endif - ! Internal physics timestep evolution. + ! + ! Simulate internal physics timestep evolution. + ! do iprc = proc_start,proc_end - if (iprc == iactive_scheme(iactive_scheme_inloop)) then - print*,'Reached active process. ', iprc - else - print*,'Simulating ',iprc,' of ',proc_end - endif - do iCol = 1,nCol + ! Reset locals physics_process(iprc)%tend1d%T(:) = 0. physics_process(iprc)%tend1d%u(:) = 0. physics_process(iprc)%tend1d%v(:) = 0. physics_process(iprc)%tend1d%q(:) = 0. - ! Using scheme simulator (very simple, interpolate data tendency to local time) + ! Using scheme simulator + ! Very simple... + ! Interpolate 2D data (time,level) tendency to local time. + ! Here the data is already on the SCM vertical coordinate. + ! + ! In theory the data can be of any dimensionality and the onus falls on the + ! developer to extend the type "base_physics_process" to work with for their + ! application. + ! if (physics_process(iprc)%use_sim) then if (physics_process(iprc)%name == "LWRAD") then call sim_LWRAD(year, month, day, hour, min, sec, physics_process(iprc)) @@ -236,24 +129,15 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti endif ! Using data tendency from "active" scheme(s). - ! DJS2023: This block is very ufs specific. See Note Above. else - idtend = dtidx(index_of_temperature,index_of_active_process) - if (idtend >= 1) physics_process(iprc)%tend1d%T = dtend(iCol,:,idtend)/dtp - ! - idtend = dtidx(index_of_x_wind,index_of_active_process) - if (idtend >= 1) physics_process(iprc)%tend1d%u = dtend(iCol,:,idtend)/dtp - ! - idtend = dtidx(index_of_y_wind,index_of_active_process) - if (idtend >= 1) physics_process(iprc)%tend1d%v = dtend(iCol,:,idtend)/dtp - ! - idtend = dtidx(100+ntqv,index_of_active_process) - if (idtend >= 1) physics_process(iprc)%tend1d%q = dtend(iCol,:,idtend)/dtp + physics_process(iprc)%tend1d%T = active_phys_tend(iCol,:,1) + physics_process(iprc)%tend1d%u = active_phys_tend(iCol,:,2) + physics_process(iprc)%tend1d%v = active_phys_tend(iCol,:,3) + physics_process(iprc)%tend1d%q = active_phys_tend(iCol,:,4) endif - ! Update state now? + ! Update state now? (time-split scheme) if (physics_process(iprc)%time_split) then - print*,' time-split scheme...' gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp @@ -262,25 +146,31 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti dudt(iCol,:) = 0. dvdt(iCol,:) = 0. dqdt(iCol,:) = 0. - ! Accumulate tendencies, update later? + ! Accumulate tendencies, update later? (process-split scheme) else - print*,' process-split scheme...' dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q endif + enddo ! END: Loop over columns + enddo ! END: Loop over physics processes + + ! + ! Update state with accumulated tendencies (process-split only) + ! + if (.not. physics_process(iprc)%time_split) then + do iCol = 1,nCol + gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp + gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp + gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp + gq0(iCol,:) = gq1(iCol,:) + dqdt(iCol,:)*dtp enddo - ! - do iLay=1,nLay - !write(*,'(i3,4f13.6)') ilay, gq0(iCol,iLay) , gq1(iCol,iLay) , dqdt(iCol,iLay)*dtp, physics_process(iprc)%tend1d%q(iLay)*dtp - enddo - gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp - gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp - gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp - gq0(iCol,:) = gq1(iCol,:) + dqdt(iCol,:)*dtp - enddo + endif + ! + ! Update bookeeping indices + ! if (in_pre_active) then in_pre_active = .false. in_post_active = .true. @@ -296,224 +186,6 @@ subroutine ccpp_scheme_simulator_run(kdt, dtp, jdat, tgrs, ugrs, vgrs, qgrs, dti iactive_scheme_inloop = iactive_scheme_inloop + 1 endif - ! end subroutine ccpp_scheme_simulator_run - ! #################################################################################### - ! Type-bound procedure to compute tendency profile for time-of-day. - ! - ! For use with 1D data (level, time) tendencies with diurnal (24-hr) forcing. - ! #################################################################################### - function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err_message) - class(base_physics_process), intent(inout) :: this - character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: err_message - integer :: ti(1), tf(1) - real(kind_phys) :: w1, w2 - - ! Interpolation weights - call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) - - select case(var_name) - case("T") - this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) - case("u") - this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) - case("v") - this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) - case("q") - this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) - end select - - end function linterp_1D - - ! #################################################################################### - ! Type-bound procedure to compute tendency profile for time-of-day. - ! - ! For use with 2D data (location, level, time) tendencies with diurnal (24-hr) forcing. - ! This assumes that the location dimension has a [longitude, latitude] associated with - ! each location. - ! #################################################################################### - function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) result(err_message) - class(base_physics_process), intent(inout) :: this - character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, min, sec - real(kind_phys), intent(in) :: lon, lat - character(len=128) :: err_message - integer :: ti(1), tf(1), iNearest - real(kind_phys) :: w1, w2 - - ! Interpolation weights (temporal) - call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) - - ! Grab data tendency closest to column [lon,lat] - iNearest = this%find_nearest_loc_2d_1d(lon,lat) - - select case(var_name) - case("T") - this%tend1d%T = w1*this%tend3d%T(iNearest,:,ti(1)) + w2*this%tend3d%T(iNearest,:,tf(1)) - case("u") - this%tend1d%u = w1*this%tend3d%u(iNearest,:,ti(1)) + w2*this%tend3d%u(iNearest,:,tf(1)) - case("v") - this%tend1d%v = w1*this%tend3d%v(iNearest,:,ti(1)) + w2*this%tend3d%v(iNearest,:,tf(1)) - case("q") - this%tend1d%q = w1*this%tend3d%q(iNearest,:,ti(1)) + w2*this%tend3d%q(iNearest,:,tf(1)) - end select - end function linterp_2D - - ! #################################################################################### - ! Type-bound procedure to find nearest location. - ! - ! For use with linterp_2D, NOT YET IMPLEMENTED. - ! #################################################################################### - pure function find_nearest_loc_2d_1d(this, lon, lat) - class(base_physics_process), intent(in) :: this - real(kind_phys), intent(in) :: lon, lat - integer :: find_nearest_loc_2d_1d - - find_nearest_loc_2d_1d = 1 - end function find_nearest_loc_2d_1d - - ! #################################################################################### - ! Type-bound procedure to compute linear interpolation weights for a diurnal (24-hour) - ! forcing. - ! #################################################################################### - subroutine cmp_time_wts(this, year, month, day, hour, minute, sec, w1, w2, ti, tf) - ! Inputs - class(base_physics_process), intent(in) :: this - integer, intent(in) :: year, month, day, hour, minute, sec - ! Outputs - integer,intent(out) :: ti(1), tf(1) - real(kind_phys),intent(out) :: w1, w2 - ! Locals - real(kind_phys) :: hrofday - - hrofday = hour*3600. + minute*60. + sec - ti = max(hour,1) - tf = min(ti + 1,24) - w1 = ((hour+1)*3600 - hrofday)/3600 - w2 = 1 - w1 - - end subroutine cmp_time_wts - - ! #################################################################################### - subroutine sim_LWRAD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - - end subroutine sim_LWRAD - - ! #################################################################################### - subroutine sim_SWRAD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - - end subroutine sim_SWRAD - - ! #################################################################################### - subroutine sim_GWD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - - end subroutine sim_GWD - - ! #################################################################################### - subroutine sim_PBL( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_PBL - - ! #################################################################################### - subroutine sim_DCNV( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_DCNV - - ! #################################################################################### - subroutine sim_SCNV( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_SCNV - - ! #################################################################################### - subroutine sim_cldMP( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (associated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (associated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - end subroutine sim_cldMP - end module ccpp_scheme_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 888ba2f8d..777d2248e 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -1,12 +1,18 @@ [ccpp-table-properties] name = ccpp_scheme_simulator type = scheme - dependencies = machine.F + dependencies = machine.F,module_ccpp_scheme_simulator.F90 -######################################################################## [ccpp-arg-table] name = ccpp_scheme_simulator_run type = scheme +[do_ccpp_scheme_sim] + standard_name = flag_for_ccpp_scheme_simulator + long_name = flag for ccpp scheme simulator + units = flag + dimensions = () + type = logical + intent = in [kdt] standard_name = index_of_timestep long_name = current forecast iteration @@ -14,6 +20,20 @@ dimensions = () type = integer intent = in +[nCol] + standard_name = horizontal_loop_extent + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nLay] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in [dtp] standard_name = timestep_for_physics long_name = physics timestep @@ -29,6 +49,70 @@ dimensions = (8) type = integer intent = in +[nactive_proc] + standard_name = number_of_active_physics_process_in_CCPP_scheme_simulator + long_name = number of active physics process in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[proc_start] + standard_name = index_for_first_physics_process_in_CCPP_scheme_simulator + long_name = index for first physics process in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = inout +[proc_end] + standard_name = index_for_last_physics_process_in_CCPP_scheme_simulator + long_name = index for last physics process in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = inout +[iactive_scheme_inloop] + standard_name = count_for_active_scheme_in_CCPP_scheme_simulator + long_name = count for active physics scheme in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = inout +[in_pre_active] + standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_scheme + long_name = flag to indicate location in physics process loop before active scheme + units = flag + dimensions = () + type = logical + intent = inout +[in_post_active] + standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_scheme + long_name = flag to indicate location in physics process loop after active scheme + units = flag + dimensions = () + type = logical + intent = inout +[active_name] + standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator + long_name = name of active physics schemes in CCPP scheme simulator + units = + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = character + kind = len=16 + intent = in +[iactive_scheme] + standard_name = index_of_active_physics_schemes_in_CCPP_scheme_simulator + long_name = index of active physics schemes in CCPP scheme simulator + units = count + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = integer + intent = in +[active_time_split_process] + standard_name = flag_to_indicate_process_type_in_CCPP_scheme_simulator + long_name = flag to indicate if active physics schemes are time-split process + units = flag + dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) + type = logical + intent = in [tgrs] standard_name = air_temperature long_name = model layer mean temperature @@ -61,98 +145,14 @@ type = real kind = kind_phys intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables +[active_phys_tend] + standard_name = tendencies_for_active_process_in_ccpp_scheme_simulator + long_name = tendencies for active physics process in ccpp scheme simulator units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_scheme_simulator) type = real kind = kind_phys intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_longwave] - standard_name = index_of_longwave_heating_process_in_cumulative_change_index - long_name = index of longwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_shortwave] - standard_name = index_of_shortwave_heating_process_in_cumulative_change_index - long_name = index of shortwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_orographic_gwd] - standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_pbl] - standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index - long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_mp] - standard_name = index_of_microphysics_process_process_in_cumulative_change_index - long_name = index of microphysics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in [gt0] standard_name = air_temperature_of_new_state long_name = temperature updated by physics @@ -201,6 +201,13 @@ type = real kind = kind_phys intent = inout +[physics_process] + standard_name = physics_process_type_for_CCPP_scheme_simulator + long_name = physics process type for CCPP scheme simulator + units = mixed + dimensions = (number_of_physics_process_in_CCPP_scheme_simulator) + type = base_physics_process + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_ccpp_scheme_simulator.F90 b/physics/module_ccpp_scheme_simulator.F90 new file mode 100644 index 000000000..a0756ab61 --- /dev/null +++ b/physics/module_ccpp_scheme_simulator.F90 @@ -0,0 +1,302 @@ +! ######################################################################################## +! +! This module contains the type, base_physics_process, and supporting subroutines needed +! by the ccpp scheme simulator. +! +! ######################################################################################## +module module_ccpp_scheme_simulator +!> \section arg_table_module_ccpp_scheme_simulator Argument table +!! \htmlinclude module_ccpp_scheme_simulator.html +!! + use machine, only : kind_phys + implicit none + + public base_physics_process + + ! Type containing 1D (time) physics tendencies. + type phys_tend_1d + real(kind_phys), dimension(:), pointer :: T + real(kind_phys), dimension(:), pointer :: u + real(kind_phys), dimension(:), pointer :: v + real(kind_phys), dimension(:), pointer :: q + end type phys_tend_1d + + ! Type containing 2D (lev,time) physics tendencies. + type phys_tend_2d + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:,:), pointer :: T + real(kind_phys), dimension(:,:), pointer :: u + real(kind_phys), dimension(:,:), pointer :: v + real(kind_phys), dimension(:,:), pointer :: q + end type phys_tend_2d + + ! Type containing 3D (loc,lev,time) physics tendencies. + type phys_tend_3d + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:), pointer :: lon + real(kind_phys), dimension(:), pointer :: lat + real(kind_phys), dimension(:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:), pointer :: q + end type phys_tend_3d + + ! Type containing 4D (lon, lat,lev,time) physics tendencies. + type phys_tend_4d + real(kind_phys), dimension(:), pointer :: time + real(kind_phys), dimension(:,:), pointer :: lon + real(kind_phys), dimension(:,:), pointer :: lat + real(kind_phys), dimension(:,:,:,:), pointer :: T + real(kind_phys), dimension(:,:,:,:), pointer :: u + real(kind_phys), dimension(:,:,:,:), pointer :: v + real(kind_phys), dimension(:,:,:,:), pointer :: q + end type phys_tend_4d + +! This type contains the meta information and data for each physics process. + +!> \section arg_table_base_physics_process Argument Table +!! \htmlinclude base_physics_process.html +!! + type base_physics_process + character(len=16) :: name + logical :: time_split = .false. + logical :: use_sim = .false. + integer :: order + type(phys_tend_1d) :: tend1d + type(phys_tend_2d) :: tend2d + type(phys_tend_3d) :: tend3d + type(phys_tend_4d) :: tend4d + contains + generic, public :: linterp => linterp_1D, linterp_2D + procedure, private :: linterp_1D + procedure, private :: linterp_2D + procedure, public :: find_nearest_loc_2d_1d + procedure, public :: cmp_time_wts + end type base_physics_process + +contains + + ! #################################################################################### + ! Type-bound procedure to compute tendency profile for time-of-day. + ! + ! For use with 1D data (level, time) tendencies with diurnal (24-hr) forcing. + ! #################################################################################### + function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err_message) + class(base_physics_process), intent(inout) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: err_message + integer :: ti(1), tf(1) + real(kind_phys) :: w1, w2 + + ! Interpolation weights + call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) + + select case(var_name) + case("T") + this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) + case("u") + this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) + case("v") + this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) + case("q") + this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) + end select + + end function linterp_1D + + ! #################################################################################### + ! Type-bound procedure to compute tendency profile for time-of-day. + ! + ! For use with 2D data (location, level, time) tendencies with diurnal (24-hr) forcing. + ! This assumes that the location dimension has a [longitude, latitude] associated with + ! each location. + ! #################################################################################### + function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) result(err_message) + class(base_physics_process), intent(inout) :: this + character(len=*), intent(in) :: var_name + integer, intent(in) :: year, month, day, hour, min, sec + real(kind_phys), intent(in) :: lon, lat + character(len=128) :: err_message + integer :: ti(1), tf(1), iNearest + real(kind_phys) :: w1, w2 + + ! Interpolation weights (temporal) + call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) + + ! Grab data tendency closest to column [lon,lat] + iNearest = this%find_nearest_loc_2d_1d(lon,lat) + + select case(var_name) + case("T") + this%tend1d%T = w1*this%tend3d%T(iNearest,:,ti(1)) + w2*this%tend3d%T(iNearest,:,tf(1)) + case("u") + this%tend1d%u = w1*this%tend3d%u(iNearest,:,ti(1)) + w2*this%tend3d%u(iNearest,:,tf(1)) + case("v") + this%tend1d%v = w1*this%tend3d%v(iNearest,:,ti(1)) + w2*this%tend3d%v(iNearest,:,tf(1)) + case("q") + this%tend1d%q = w1*this%tend3d%q(iNearest,:,ti(1)) + w2*this%tend3d%q(iNearest,:,tf(1)) + end select + end function linterp_2D + + ! #################################################################################### + ! Type-bound procedure to find nearest location. + ! For use with linterp_2D, NOT YET IMPLEMENTED. + ! #################################################################################### + pure function find_nearest_loc_2d_1d(this, lon, lat) + class(base_physics_process), intent(in) :: this + real(kind_phys), intent(in) :: lon, lat + integer :: find_nearest_loc_2d_1d + + find_nearest_loc_2d_1d = 1 + end function find_nearest_loc_2d_1d + + ! #################################################################################### + ! Type-bound procedure to compute linear interpolation weights for a diurnal (24-hour) + ! forcing. + ! #################################################################################### + subroutine cmp_time_wts(this, year, month, day, hour, minute, sec, w1, w2, ti, tf) + ! Inputs + class(base_physics_process), intent(in) :: this + integer, intent(in) :: year, month, day, hour, minute, sec + ! Outputs + integer,intent(out) :: ti(1), tf(1) + real(kind_phys),intent(out) :: w1, w2 + ! Locals + real(kind_phys) :: hrofday + + hrofday = hour*3600. + minute*60. + sec + ti = max(hour,1) + tf = min(ti + 1,24) + w1 = ((hour+1)*3600 - hrofday)/3600 + w2 = 1 - w1 + + end subroutine cmp_time_wts + + ! #################################################################################### + ! #################################################################################### + subroutine sim_LWRAD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + + end subroutine sim_LWRAD + + ! #################################################################################### + ! #################################################################################### + subroutine sim_SWRAD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + + end subroutine sim_SWRAD + + ! #################################################################################### + ! #################################################################################### + subroutine sim_GWD( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + + end subroutine sim_GWD + + ! #################################################################################### + ! #################################################################################### + subroutine sim_PBL( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_PBL + + ! #################################################################################### + ! #################################################################################### + subroutine sim_DCNV( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_DCNV + + ! #################################################################################### + ! #################################################################################### + subroutine sim_SCNV( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%u)) then + errmsg = process%linterp("u", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%v)) then + errmsg = process%linterp("v", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + + end subroutine sim_SCNV + + ! #################################################################################### + ! #################################################################################### + subroutine sim_cldMP( year, month, day, hour, min, sec, process) + type(base_physics_process), intent(inout) :: process + integer, intent(in) :: year, month, day, hour, min, sec + character(len=128) :: errmsg + + if (associated(process%tend2d%T)) then + errmsg = process%linterp("T", year,month,day,hour,min,sec) + endif + if (associated(process%tend2d%q)) then + errmsg = process%linterp("q", year,month,day,hour,min,sec) + endif + end subroutine sim_cldMP + +end module module_ccpp_scheme_simulator diff --git a/physics/module_ccpp_scheme_simulator.meta b/physics/module_ccpp_scheme_simulator.meta new file mode 100644 index 000000000..8eefb228c --- /dev/null +++ b/physics/module_ccpp_scheme_simulator.meta @@ -0,0 +1,24 @@ +[ccpp-table-properties] + name = base_physics_process + type = ddt + dependencies = + +[ccpp-arg-table] + name = base_physics_process + type = ddt + +######################################################################## +[ccpp-table-properties] + name = module_ccpp_scheme_simulator + type = module + dependencies = machine.F + +[ccpp-arg-table] + name = module_ccpp_scheme_simulator + type = module +[base_physics_process] + standard_name = base_physics_process + long_name = definition of type base_physics_process + units = DDT + dimensions = () + type = base_physics_process From 5d49f7942f4863441cc2678844a7b744952c9006 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 1 Jun 2023 13:48:56 -0600 Subject: [PATCH 21/64] Reorganization of scheme simulator. Now stateless. --- physics/GFS_ccpp_scheme_sim_pre.F90 | 745 ++++++++--------------- physics/GFS_ccpp_scheme_sim_pre.meta | 158 +---- physics/ccpp_scheme_simulator.F90 | 26 +- physics/ccpp_scheme_simulator.meta | 52 -- physics/load_ccpp_scheme_sim.F90 | 588 ------------------ physics/load_ccpp_scheme_sim.meta | 60 -- physics/module_ccpp_scheme_simulator.F90 | 111 ++-- 7 files changed, 334 insertions(+), 1406 deletions(-) delete mode 100644 physics/load_ccpp_scheme_sim.F90 delete mode 100644 physics/load_ccpp_scheme_sim.meta diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 index acd0c6692..31bafff01 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -1,391 +1,222 @@ ! ######################################################################################## ! ! Interstitial CCPP scheme to couple UFS physics to ccpp_scheme_simulator. -! ) _init: read and load data into type used by ccpp_scheme_simulator -! ) _run: prepare GFS diagnostic physics tendencies for ccpp_scheme_simulator +! ) load: read and load data into type used by ccpp_scheme_simulator +! ) _run: prepare GFS diagnostic physics tendencies for ccpp_scheme_simulator ! ! ######################################################################################## module GFS_ccpp_scheme_sim_pre use machine, only: kind_phys - use netcdf use module_ccpp_scheme_simulator, only: base_physics_process -#ifdef MPI - use mpi -#endif + use netcdf implicit none - - public GFS_ccpp_scheme_sim_pre_init, GFS_ccpp_scheme_sim_pre_run + public GFS_ccpp_scheme_sim_pre_run, load_ccpp_scheme_sim contains ! ###################################################################################### ! - ! SUBROUTINE GFS_ccpp_scheme_sim_pre_init + ! SUBROUTINE GFS_ccpp_scheme_sim_pre_run ! ! ###################################################################################### -!! \section arg_table_GFS_ccpp_scheme_sim_pre_init -!! \htmlinclude GFS_ccpp_scheme_sim_pre_init.html -!! - subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_scheme_sim, & - scheme_sim_data, nprg_active, nprc_sim, prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg,& - prc_GWD_cfg, prc_SCNV_cfg, prc_DCNV_cfg, prc_cldMP_cfg, active_name, & - iactive_scheme, active_time_split_process, physics_process, errmsg, errflg) +!! \section arg_table_GFS_ccpp_scheme_sim_pre_run +!! \htmlinclude GFS_ccpp_scheme_sim_pre_run.html +!! + subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process_dcnv, & + index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind, & + physics_process, active_phys_tend, errmsg, errflg) ! Inputs - integer, intent (in) :: mpirank, mpiroot, mpicomm, nprg_active, nprc_sim - logical, intent (in) :: do_ccpp_scheme_sim - character(len=256), intent (in) :: scheme_sim_data - integer, dimension(3), intent (in) :: prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, & - prc_GWD_cfg, prc_SCNV_cfg, prc_DCNV_cfg, prc_cldMP_cfg + integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & + index_of_process_shortwave, index_of_process_scnv, & + index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & + index_of_temperature, index_of_x_wind, index_of_y_wind + integer, intent(in), dimension(:,:) :: dtidx + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in), dimension(:,:,:) :: dtend + type(base_physics_process),intent(in) :: physics_process(:) ! Outputs - type(base_physics_process),intent(inout) :: physics_process(:) - character(len=16),intent(inout) :: active_name(:) - integer, intent(inout) :: iactive_scheme(:) - logical, intent(inout) :: active_time_split_process(:) - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + real(kind_phys), intent(out) :: active_phys_tend(:,:,:) + character(len=*),intent(out) :: errmsg + integer, intent(out) :: errflg - ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc, iactive - logical :: exists - - ! Switches for input data - logical :: have_dTdt_LWRAD_data = .false., & - have_dTdt_SWRAD_data = .false., & - have_dTdt_PBL_data = .false., & - have_dqdt_PBL_data = .false., & - have_dudt_PBL_data = .false., & - have_dvdt_PBL_data = .false., & - have_dTdt_GWD_data = .false., & - have_dudt_GWD_data = .false., & - have_dvdt_GWD_data = .false., & - have_dTdt_SCNV_data = .false., & - have_dudt_SCNV_data = .false., & - have_dvdt_SCNV_data = .false., & - have_dqdt_SCNV_data = .false., & - have_dTdt_DCNV_data = .false., & - have_dudt_DCNV_data = .false., & - have_dvdt_DCNV_data = .false., & - have_dqdt_DCNV_data = .false., & - have_dTdt_cldMP_data = .false., & - have_dqdt_cldMP_data = .false. - - ! Data driven physics tendencies - integer :: nlev_data, ntime_data - real(kind_phys), allocatable, dimension(:), target :: time_data - real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & - dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & - dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & - dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:), target :: dqdt_PBL_data, & - dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data + ! Locals + integer :: idtend, iactive ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - if (.not. do_ccpp_scheme_sim) return - + ! Get tendency for "active" process. + ! ###################################################################################### + ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional + ! array, CCPP standard_name = cumulative_change_of_state_variables. + ! These are not the instantaneous physics tendencies that are applied to the state by + ! the physics schemes. Not all schemes output physics tendencies... + ! Rather these are intended for diagnostic puposes and are accumulated over some + ! interval. + ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option + ! "fhzero". For this to work, you need to clear the diagnostic buckets after each + ! physics timestep when running in the UFS/SCM. ! - ! Part A) Read in data. + ! In the SCM this is done by adding the following runtime options: + ! --n_itt_out 1 --n_itt_diag 1 ! ! ###################################################################################### - - ! Check that input data file exists - inquire (file = trim (scheme_sim_data), exist = exists) + if (physics_process(1)%active_name == "LWRAD") iactive = index_of_process_longwave + if (physics_process(1)%active_name == "SWRAD") iactive = index_of_process_shortwave + if (physics_process(1)%active_name == "PBL") iactive = index_of_process_pbl + if (physics_process(1)%active_name == "GWD") iactive = index_of_process_orographic_gwd + if (physics_process(1)%active_name == "SCNV") iactive = index_of_process_scnv + if (physics_process(1)%active_name == "DCNV") iactive = index_of_process_dcnv + if (physics_process(1)%active_name == "cldMP") iactive = index_of_process_mp + + ! Heat + idtend = dtidx(index_of_temperature,iactive) + if (idtend >= 1) active_phys_tend(:,:,1) = dtend(:,:,idtend)/dtp + ! u-wind + idtend = dtidx(index_of_x_wind,iactive) + if (idtend >= 1) active_phys_tend(:,:,2) = dtend(:,:,idtend)/dtp + ! v-wind + idtend = dtidx(index_of_y_wind,iactive) + if (idtend >= 1) active_phys_tend(:,:,3) = dtend(:,:,idtend)/dtp + ! Moisture + idtend = dtidx(100+ntqv,iactive) + if (idtend >= 1) active_phys_tend(:,:,4) = dtend(:,:,idtend)/dtp + + + end subroutine GFS_ccpp_scheme_sim_pre_run + + ! ###################################################################################### + subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, & + errmsg, errflg) + + ! Inputs + integer, intent (in) :: nlunit + character(len=*), intent (in) :: nml_file + + ! Outputs + type(base_physics_process),intent(inout),allocatable :: physics_process(:) + integer, intent(out) :: nprg_active + integer, intent(out) :: errflg + character(len=256), intent(out) :: errmsg + + ! Local variables + integer :: ncid, dimID, varID, status, ios, iprc, nlev_data, ntime_data + character(len=256) :: scheme_sim_file + logical :: exists, do_ccpp_scheme_sim + integer :: nprc_sim + + ! For each process there is a corresponding namelist entry, which is constructed as follows: + ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} + integer, dimension(3) :: & + prc_LWRAD_cfg = (/0,0,0/), & + prc_SWRAD_cfg = (/0,0,0/), & + prc_PBL_cfg = (/0,0,0/), & + prc_GWD_cfg = (/0,0,0/), & + prc_SCNV_cfg = (/0,0,0/), & + prc_DCNV_cfg = (/0,0,0/), & + prc_cldMP_cfg = (/0,0,0/) + + ! Namelist + namelist / ccpp_scheme_sim_nml / do_ccpp_scheme_sim, scheme_sim_file, nprc_sim, & + prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, prc_GWD_cfg, prc_SCNV_cfg, & + prc_DCNV_cfg, prc_cldMP_cfg + + errmsg = '' + errflg = 0 + + ! Read in namelist + inquire (file = trim (nml_file), exist = exists) if (.not. exists) then - errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not exist' + errmsg = 'CCPP scheme simulator namelist file: '//trim(nml_file)//' does not exist.' + errflg = 1 + return + else + open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) + endif + rewind (nlunit) + read (nlunit, nml = ccpp_scheme_sim_nml, iostat=status) + close (nlunit) + + ! Only proceed if scheme simulator requested. + if (prc_SWRAD_cfg(1) .or. prc_LWRAD_cfg(1) .or. prc_PBL_cfg(1) .or. & + prc_GWD_cfg(1) .or. prc_SCNV_cfg(1) .or. prc_DCNV_cfg(1) .or. & + prc_cldMP_cfg(1)) then + else + return + endif + + ! Check that input data file exists. + inquire (file = trim (scheme_sim_file), exist = exists) + if (.not. exists) then + errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not exist' errflg = 1 return endif - ! Read mandatory information from data file... - ! (ONLY master processor(0), if MPI enabled) -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif + ! + ! Read data file... + ! - ! Open file (required) - status = nf90_open(trim(scheme_sim_data), NF90_NOWRITE, ncid) - if (status /= nf90_noerr) then - errmsg = 'Error reading in SCM data tendency file: '//trim(scheme_sim_data) - errflg = 1 - return - endif - - ! Get dimensions (required) - status = nf90_inq_dimid(ncid, 'time', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) - else - errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain [time] dimension' - errflg = 1 - return - endif - ! - status = nf90_inq_dimid(ncid, 'lev', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) - else - errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain [lev] dimension' - errflg = 1 - return - endif -#ifdef MPI - endif ! On master processor - - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - - ! Broadcast dimensions... - ! (ALL processors) - call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_barrier(mpicomm, mpierr) - - if (mpirank .eq. mpiroot) then -#endif - - ! - ! What data fields do we have? - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) have_dTdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) have_dqdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) have_dudt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) have_dvdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) have_dTdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) have_dudt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) have_dvdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) have_dTdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) have_dudt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) have_dvdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) have_dqdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) have_dTdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) have_dudt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) have_dvdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) have_dqdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) have_dTdt_cldMP_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) have_dqdt_cldMP_data = .true. - -#ifdef MPI - endif ! Master process -#endif - - ! Allocate space for data - allocate(time_data(ntime_data)) - if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) - if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data)) - if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) - if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) - if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) - if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) - if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) - if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) - if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) - if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) - if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data)) - if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) - if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) - if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) - if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data)) - if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) - if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data)) - - ! Read in data ... - ! (ONLY master processor(0), if MPI enabled) -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif - - ! Temporal info (required) + ! Open file + status = nf90_open(trim(scheme_sim_file), NF90_NOWRITE, ncid) + if (status /= nf90_noerr) then + errmsg = 'Error reading in CCPP scheme simulator file: '//trim(scheme_sim_file) + errflg = 1 + return + endif + + ! Metadata (dimensions) + status = nf90_inq_dimid(ncid, 'time', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) + else + errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not contain [time] dimension' + errflg = 1 + return + endif + + status = nf90_inq_dimid(ncid, 'lev', dimid) + if (status == nf90_noerr) then + status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) + else + errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not contain [lev] dimension' + errflg = 1 + return + endif + + ! Allocate space and read in data + allocate(physics_process(nprc_sim)) + physics_process(1)%active_name = '' + physics_process(1)%iactive_scheme = 0 + physics_process(1)%active_tsp = .false. + do iprc = 1,nprc_sim + allocate(physics_process(iprc)%tend1d%T( nlev_data )) + allocate(physics_process(iprc)%tend1d%u( nlev_data )) + allocate(physics_process(iprc)%tend1d%v( nlev_data )) + allocate(physics_process(iprc)%tend1d%q( nlev_data )) + allocate(physics_process(iprc)%tend2d%time( ntime_data)) + allocate(physics_process(iprc)%tend2d%T( nlev_data, ntime_data)) + allocate(physics_process(iprc)%tend2d%u( nlev_data, ntime_data)) + allocate(physics_process(iprc)%tend2d%v( nlev_data, ntime_data)) + allocate(physics_process(iprc)%tend2d%q( nlev_data, ntime_data)) + + ! Temporal info status = nf90_inq_varid(ncid, 'times', varID) if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, time_data) + status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%time) else - errmsg = 'SCM data tendency file: '//trim(scheme_sim_data)//' does not contain times variable' + errmsg = 'SCM data tendency file: '//trim(scheme_sim_file)//' does not contain times variable' errflg = 1 return endif - - ! Read in physics data tendencies (optional) - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) - ! - status = nf90_close(ncid) - -#ifdef MPI - endif ! Master process - - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - - ! Broadcast data... - ! (ALL processors) - if (have_dTdt_LWRAD_data) then - call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SWRAD_data) then - call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_PBL_data) then - call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_PBL_data) then - call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_PBL_data) then - call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_PBL_data) then - call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_GWD_data) then - call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_GWD_data) then - call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_GWD_data) then - call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SCNV_data) then - call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_SCNV_data) then - call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_SCNV_data) then - call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_SCNV_data) then - call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_DCNV_data) then - call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_DCNV_data) then - call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_DCNV_data) then - call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_DCNV_data) then - call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_cldMP_data) then - call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_cldMP_data) then - call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - ! - call mpi_barrier(mpicomm, mpierr) -#endif - - ! ####################################################################################### - ! - ! Part B) Populate physics_process type. - ! - ! ####################################################################################### - ! Metadata - do iprc = 1,nprc_sim if (iprc == prc_SWRAD_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "SWRAD" if (prc_SWRAD_cfg(1) == 1) then @@ -394,8 +225,14 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_SWRAD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + nprg_active = 1 endif + if (iprc == prc_LWRAD_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "LWRAD" if (prc_LWRAD_cfg(1) == 1) then @@ -404,8 +241,14 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_LWRAD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + nprg_active =1 endif + if (iprc == prc_GWD_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "GWD" if (prc_GWD_cfg(1) == 1) then @@ -414,8 +257,18 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_GWD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) + status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) + nprg_active = 3 endif + if (iprc == prc_PBL_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "PBL" if (prc_PBL_cfg(1) == 1) then @@ -424,8 +277,20 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_PBL_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) + status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) + status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) + nprg_active = 4 endif + if (iprc == prc_SCNV_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "SCNV" if (prc_SCNV_cfg(1) == 1) then @@ -434,8 +299,20 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_SCNV_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) + status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) + status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) + nprg_active = 4 endif + if (iprc == prc_DCNV_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "DCNV" if (prc_DCNV_cfg(1) == 1) then @@ -444,8 +321,20 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_DCNV_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) + status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) + status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) + nprg_active = 4 endif + if (iprc == prc_cldMP_cfg(3)) then + ! Metadata physics_process(iprc)%order = iprc physics_process(iprc)%name = "cldMP" if (prc_cldMP_cfg(1) == 1) then @@ -454,150 +343,48 @@ subroutine GFS_ccpp_scheme_sim_pre_init(mpirank, mpiroot, mpicomm, do_ccpp_schem if (prc_cldMP_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data + status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) + status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) + if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) + nprg_active = 2 endif - enddo - ! Load data - physics_process(prc_LWRAD_cfg(3))%tend2d%time => time_data - physics_process(prc_SWRAD_cfg(3))%tend2d%time => time_data - physics_process(prc_PBL_cfg(3))%tend2d%time => time_data - physics_process(prc_GWD_cfg(3))%tend2d%time => time_data - physics_process(prc_DCNV_cfg(3))%tend2d%time => time_data - physics_process(prc_SCNV_cfg(3))%tend2d%time => time_data - physics_process(prc_cldMP_cfg(3))%tend2d%time => time_data - if (have_dTdt_LWRAD_data) physics_process(prc_SWRAD_cfg(3))%tend2d%T => dTdt_LWRAD_data - if (have_dTdt_SWRAD_data) physics_process(prc_LWRAD_cfg(3))%tend2d%T => dTdt_SWRAD_data - if (have_dTdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%T => dTdt_PBL_data - if (have_dudt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%u => dudt_PBL_data - if (have_dvdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%v => dvdt_PBL_data - if (have_dqdt_PBL_data) physics_process(prc_PBL_cfg(3))%tend2d%q => dqdt_PBL_data - if (have_dTdt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%T => dTdt_GWD_data - if (have_dudt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%u => dudt_GWD_data - if (have_dvdt_GWD_data) physics_process(prc_GWD_cfg(3))%tend2d%v => dvdt_GWD_data - if (have_dTdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%T => dTdt_SCNV_data - if (have_dudt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%u => dudt_SCNV_data - if (have_dvdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%v => dvdt_SCNV_data - if (have_dqdt_SCNV_data) physics_process(prc_SCNV_cfg(3))%tend2d%q => dqdt_SCNV_data - if (have_dTdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%T => dTdt_DCNV_data - if (have_dudt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%u => dudt_DCNV_data - if (have_dvdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%v => dvdt_DCNV_data - if (have_dqdt_DCNV_data) physics_process(prc_DCNV_cfg(3))%tend2d%q => dqdt_DCNV_data - if (have_dTdt_cldMP_data) physics_process(prc_cldMP_cfg(3))%tend2d%T => dTdt_cldMP_data - if (have_dqdt_cldMP_data) physics_process(prc_cldMP_cfg(3))%tend2d%q => dqdt_cldMP_data - - ! Which process-scheme(s) is(are) "Active"? Are they time-split process? - iactive = 0 - active_time_split_process(:) = .false. - do iprc = 1,nprc_sim + ! Which process-scheme is "active"? Is process time-split? if (.not. physics_process(iprc)%use_sim) then - iactive = iactive + 1 - iactive_scheme(iactive) = iprc - active_name(iactive) = physics_process(iprc)%name + physics_process(1)%iactive_scheme = iprc + physics_process(1)%active_name = physics_process(iprc)%name if (physics_process(iprc)%time_split) then - active_time_split_process(iactive) = .true. + physics_process(1)%active_tsp = .true. endif endif + enddo - ! - if (mpirank .eq. mpiroot) then - print*, "-----------------------------------" - print*, "--- Using CCPP scheme simulator ---" - print*, "-----------------------------------" - iactive = 1 - do iprc = 1,nprc_sim - if (physics_process(iprc)%use_sim) then - print*," simulate_scheme: ", trim(physics_process(iprc)%name) - print*," order: ", physics_process(iprc)%order - print*," time_split: ", physics_process(iprc)%time_split - else - print*, " active_scheme: ", trim(active_name(iactive)) - print*, " order: ", physics_process(iactive_scheme(iactive))%order - print*, " time_split : ", active_time_split_process(iactive) - iactive = iactive + 1 - endif - enddo - print*, "-----------------------------------" - print*, "-----------------------------------" + if (physics_process(1)%iactive_scheme == 0) then + errflg = 1 + errmsg = "ERROR: No active scheme set for CCPP scheme simulator" + return endif - end subroutine GFS_ccpp_scheme_sim_pre_init - - ! ###################################################################################### - ! - ! SUBROUTINE GFS_ccpp_scheme_sim_pre_run - ! - ! ###################################################################################### -!! \section arg_table_GFS_ccpp_scheme_sim_pre_run -!! \htmlinclude GFS_ccpp_scheme_sim_pre_run.html -!! - subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process_dcnv, & - index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, & - active_name, iactive_scheme_inloop, active_phys_tend, errmsg, errflg) - - ! Inputs - integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & - index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, iactive_scheme_inloop - integer, intent(in), dimension(:,:) :: dtidx - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in), dimension(:,:,:) :: dtend - character(len=16),intent(in), dimension(:) :: active_name - - ! Outputs - real(kind_phys), intent(out) :: active_phys_tend(:,:,:) - character(len=*),intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Locals - integer :: idtend, iactive - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - ! Get tendency for "active" process. - - ! ###################################################################################### - ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional - ! array, CCPP standard_name = cumulative_change_of_state_variables. - ! These are not the instantaneous physics tendencies that are applied to the state by - ! the physics schemes. Not all schemes output physics tendencies... - ! Rather these are intended for diagnostic puposes and are accumulated over some - ! interval. - ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option - ! "fhzero". For this to work, you need to clear the diagnostic buckets after each - ! physics timestep when running in the UFS/SCM. - ! - ! In the SCM this is done by adding the following runtime options: - ! --n_itt_out 1 --n_itt_diag 1 - ! - ! ###################################################################################### - if (active_name(iactive_scheme_inloop) == "LWRAD") iactive = index_of_process_longwave - if (active_name(iactive_scheme_inloop) == "SWRAD") iactive = index_of_process_shortwave - if (active_name(iactive_scheme_inloop) == "PBL") iactive = index_of_process_pbl - if (active_name(iactive_scheme_inloop) == "GWD") iactive = index_of_process_orographic_gwd - if (active_name(iactive_scheme_inloop) == "SCNV") iactive = index_of_process_scnv - if (active_name(iactive_scheme_inloop) == "DCNV") iactive = index_of_process_dcnv - if (active_name(iactive_scheme_inloop) == "cldMP") iactive = index_of_process_mp - - ! Heat - idtend = dtidx(index_of_temperature,iactive) - if (idtend >= 1) active_phys_tend(:,:,1) = dtend(:,:,idtend)/dtp - ! u-wind - idtend = dtidx(index_of_x_wind,iactive) - if (idtend >= 1) active_phys_tend(:,:,2) = dtend(:,:,idtend)/dtp - ! v-wind - idtend = dtidx(index_of_y_wind,iactive) - if (idtend >= 1) active_phys_tend(:,:,3) = dtend(:,:,idtend)/dtp - ! Moisture - idtend = dtidx(100+ntqv,iactive) - if (idtend >= 1) active_phys_tend(:,:,4) = dtend(:,:,idtend)/dtp - + print*, "-----------------------------------" + print*, "--- Using CCPP scheme simulator ---" + print*, "-----------------------------------" + do iprc = 1,nprc_sim + if (physics_process(iprc)%use_sim) then + print*," simulate_scheme: ", trim(physics_process(iprc)%name) + print*," order: ", physics_process(iprc)%order + print*," time_split: ", physics_process(iprc)%time_split + else + print*, " active_scheme: ", trim(physics_process(1)%active_name) + print*, " order: ", physics_process(physics_process(1)%iactive_scheme)%order + print*, " time_split : ", physics_process(1)%active_tsp + endif + enddo + print*, "-----------------------------------" + print*, "-----------------------------------" - end subroutine GFS_ccpp_scheme_sim_pre_run + end subroutine load_ccpp_scheme_sim end module GFS_ccpp_scheme_sim_pre diff --git a/physics/GFS_ccpp_scheme_sim_pre.meta b/physics/GFS_ccpp_scheme_sim_pre.meta index cf7678fe6..e101e4650 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.meta +++ b/physics/GFS_ccpp_scheme_sim_pre.meta @@ -5,170 +5,14 @@ ######################################################################## [ccpp-arg-table] - name = GFS_ccpp_scheme_sim_pre_init + name = GFS_ccpp_scheme_sim_pre_run type = scheme -[mpirank] - standard_name = mpi_rank - long_name = MPI rank of current process - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = MPI rank of master process - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[prc_LWRAD_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_LWRAD - long_name = configuration for physics process in CCPP scheme simulator LWRAD - units = flag - dimensions = (3) - type = integer - intent = in -[prc_SWRAD_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_SWRAD - long_name = configuration for physics process in CCPP scheme simulator SWRAD - units = flag - dimensions = (3) - type = integer - intent = in -[prc_PBL_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_PBL - long_name = configuration for physics process in CCPP scheme simulator PBL - units = flag - dimensions = (3) - type = integer - intent = in -[prc_GWD_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_GWD - long_name = configuration for physics process in CCPP scheme simulator GWD - units = flag - dimensions = (3) - type = integer - intent = in -[prc_SCNV_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_SCNV - long_name = configuration for physics process in CCPP scheme simulator SCNV - units = flag - dimensions = (3) - type = integer - intent = in -[prc_DCNV_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_DCNV - long_name = configuration for physics process in CCPP scheme simulator DCNV - units = flag - dimensions = (3) - type = integer - intent = in -[prc_cldMP_cfg] - standard_name = configuration_for_physics_process_in_CCPP_scheme_simulator_cldMP - long_name = configuration for physics process in CCPP scheme simulator cldMP - units = flag - dimensions = (3) - type = integer - intent = in -[nprg_active] - standard_name = number_of_prognostics_varaibles_in_CCPP_scheme_simulator - long_name = number of prognostic variables used in CCPP scheme simulator - units = count - dimensions = () - type = integer - intent = in -[do_ccpp_scheme_sim] - standard_name = flag_for_ccpp_scheme_simulator - long_name = flag for ccpp scheme simulator - units = flag - dimensions = () - type = logical - intent = in -[scheme_sim_data] - standard_name = filename_for_ccpp_scheme_simulator_data_file - long_name = filename for cccpp scheme simulator data file - units = none - dimensions = () - type = character - kind = len=256 - intent = in -[nprc_sim] - standard_name = number_of_physics_process_in_CCPP_scheme_simulator - long_name = number of physics process in CCPP scheme simulator - units = count - dimensions = () - type = integer - intent = in -[active_name] - standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator - long_name = name of active physics schemes in CCPP scheme simulator - units = - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = character - kind = len=16 - intent = inout -[iactive_scheme] - standard_name = index_of_active_physics_schemes_in_CCPP_scheme_simulator - long_name = index of active physics schemes in CCPP scheme simulator - units = count - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = integer - intent = inout -[active_time_split_process] - standard_name = flag_to_indicate_process_type_in_CCPP_scheme_simulator - long_name = flag to indicate if active physics schemes are time-split process - units = flag - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = logical - intent = inout [physics_process] standard_name = physics_process_type_for_CCPP_scheme_simulator long_name = physics process type for CCPP scheme simulator units = mixed dimensions = (number_of_physics_process_in_CCPP_scheme_simulator) type = base_physics_process - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out - -######################################################################## -[ccpp-arg-table] - name = GFS_ccpp_scheme_sim_pre_run - type = scheme -[iactive_scheme_inloop] - standard_name = count_for_active_scheme_in_CCPP_scheme_simulator - long_name = count for active physics scheme in CCPP scheme simulator - units = count - dimensions = () - type = integer - intent = in -[active_name] - standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator - long_name = name of active physics schemes in CCPP scheme simulator - units = - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = character - kind = len=16 intent = in [dtend] standard_name = cumulative_change_of_state_variables diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index 21f7bfde9..e4348599f 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -22,26 +22,21 @@ module ccpp_scheme_simulator !! \htmlinclude ccpp_scheme_simulator_run.html !! subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, jdat, & - nactive_proc, proc_start, proc_end, active_name, iactive_scheme, physics_process, & - active_time_split_process, iactive_scheme_inloop, in_pre_active, in_post_active, & - tgrs, ugrs, vgrs, qgrs, active_phys_tend, gt0, gu0, gv0, gq0, dtdq_pbl, dtdq_mp, & - errmsg, errflg) + proc_start, proc_end, physics_process, in_pre_active, in_post_active, tgrs, ugrs, & + vgrs, qgrs, active_phys_tend, gt0, gu0, gv0, gq0, errmsg, errflg) ! Inputs - logical, intent(in) :: do_ccpp_scheme_sim, active_time_split_process(:) - integer, intent(in) :: kdt, nCol, nLay, nactive_proc, jdat(8), & - iactive_scheme(:) + logical, intent(in) :: do_ccpp_scheme_sim + integer, intent(in) :: kdt, nCol, nLay, jdat(8) real(kind_phys), intent(in) :: dtp, tgrs(:,:), ugrs(:,:), vgrs(:,:), qgrs(:,:,:), & active_phys_tend(:,:,:) - character(len=16), intent(in) :: active_name(:) ! Outputs type(base_physics_process),intent(inout) :: physics_process(:) - real(kind_phys), intent(inout) :: gt0(:,:), gu0(:,:), gv0(:,:), gq0(:,:), & - dtdq_pbl(:,:), dtdq_mp(:,:) + real(kind_phys), intent(inout) :: gt0(:,:), gu0(:,:), gv0(:,:), gq0(:,:) character(len=*),intent(out) :: errmsg integer, intent(out) :: errflg - integer, intent(inout) :: proc_start, proc_end, iactive_scheme_inloop + integer, intent(inout) :: proc_start, proc_end logical, intent(inout) :: in_pre_active, in_post_active ! Locals @@ -77,10 +72,10 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j ! if (in_pre_active) then proc_start = 1 - proc_end = max(1,iactive_scheme(iactive_scheme_inloop)-1) + proc_end = max(1,physics_process(1)%iactive_scheme-1) endif if (in_post_active) then - proc_start = iactive_scheme(iactive_scheme_inloop) + proc_start = physics_process(1)%iactive_scheme proc_end = size(physics_process) endif @@ -179,11 +174,6 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j if (size(physics_process)+1 == iprc) then in_pre_active = .true. in_post_active = .false. - iactive_scheme_inloop = 1 - endif - - if (iactive_scheme_inloop < nactive_proc) then - iactive_scheme_inloop = iactive_scheme_inloop + 1 endif end subroutine ccpp_scheme_simulator_run diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 777d2248e..8b2618317 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -49,13 +49,6 @@ dimensions = (8) type = integer intent = in -[nactive_proc] - standard_name = number_of_active_physics_process_in_CCPP_scheme_simulator - long_name = number of active physics process in CCPP scheme simulator - units = count - dimensions = () - type = integer - intent = in [proc_start] standard_name = index_for_first_physics_process_in_CCPP_scheme_simulator long_name = index for first physics process in CCPP scheme simulator @@ -70,13 +63,6 @@ dimensions = () type = integer intent = inout -[iactive_scheme_inloop] - standard_name = count_for_active_scheme_in_CCPP_scheme_simulator - long_name = count for active physics scheme in CCPP scheme simulator - units = count - dimensions = () - type = integer - intent = inout [in_pre_active] standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_scheme long_name = flag to indicate location in physics process loop before active scheme @@ -91,28 +77,6 @@ dimensions = () type = logical intent = inout -[active_name] - standard_name = name_of_active_physics_schemes_in_CCPP_scheme_simulator - long_name = name of active physics schemes in CCPP scheme simulator - units = - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = character - kind = len=16 - intent = in -[iactive_scheme] - standard_name = index_of_active_physics_schemes_in_CCPP_scheme_simulator - long_name = index of active physics schemes in CCPP scheme simulator - units = count - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = integer - intent = in -[active_time_split_process] - standard_name = flag_to_indicate_process_type_in_CCPP_scheme_simulator - long_name = flag to indicate if active physics schemes are time-split process - units = flag - dimensions = (number_of_active_physics_process_in_CCPP_scheme_simulator) - type = logical - intent = in [tgrs] standard_name = air_temperature long_name = model layer mean temperature @@ -185,22 +149,6 @@ type = real kind = kind_phys intent = inout -[dtdq_pbl] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - long_name = instantaneous_tendency_of_specific_humidity_due_to_PBL - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[dtdq_mp] - standard_name = instantaneous_tendency_of_specific_humidity_due_to_microphysics - long_name = moisture tendency due to microphysics - units = kg kg-1 s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout [physics_process] standard_name = physics_process_type_for_CCPP_scheme_simulator long_name = physics process type for CCPP scheme simulator diff --git a/physics/load_ccpp_scheme_sim.F90 b/physics/load_ccpp_scheme_sim.F90 deleted file mode 100644 index 1fb3dc983..000000000 --- a/physics/load_ccpp_scheme_sim.F90 +++ /dev/null @@ -1,588 +0,0 @@ -! ######################################################################################## -! -! CCPP scheme to read and load data for ccpp_scheme_simulator -! -! ######################################################################################## -module load_ccpp_scheme_sim - use machine, only: kind_phys - use netcdf - use ccpp_scheme_simulator, only: do_ccpp_scheme_simulator, physics_process, active_name,& - iactive_scheme, active_time_split_process, nactive_proc -#ifdef MPI - use mpi -#endif - implicit none - - ! ######################################################################################## - ! - ! Configuration for CCPP scheme simulator. Set in namelist. Used during initialization to - ! populate "physics_process" type array, defined in ccpp_scheme_simulator.F90 - ! - ! ######################################################################################## - - ! Number of physics process (set in namelist) - integer :: nPhysProcess - - ! For each process there is a corresponding namelist entry, which is constructed as follows: - ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} - integer, dimension(3) :: & - proc_LWRAD_config = (/0,0,0/), & - proc_SWRAD_config = (/0,0,0/), & - proc_PBL_config = (/0,0,0/), & - proc_GWD_config = (/0,0,0/), & - proc_SCNV_config = (/0,0,0/), & - proc_DCNV_config = (/0,0,0/), & - proc_cldMP_config = (/0,0,0/) - - ! Activation flag for scheme. - logical :: do_load_ccpp_scheme = .false. - - ! Data driven physics tendencies - integer :: nlev_data, ntime_data - real(kind_phys), allocatable, dimension(:), target :: time_data - real(kind_phys), allocatable, dimension(:,:), target :: dTdt_LWRAD_data, & - dTdt_SWRAD_data, dTdt_PBL_data, dudt_PBL_data, dvdt_PBL_data, dTdt_GWD_data, & - dudt_GWD_data, dvdt_GWD_data, dTdt_SCNV_data, dudt_SCNV_data, dvdt_SCNV_data, & - dTdt_DCNV_data, dudt_DCNV_data, dvdt_DCNV_data, dTdt_cldMP_data - real(kind_phys), allocatable, dimension(:,:), target :: dqdt_PBL_data, & - dqdt_SCNV_data, dqdt_DCNV_data, dqdt_cldMP_data - - ! Scheme initialization flag. - logical :: module_initialized = .false. - - public load_ccpp_scheme_sim_init -contains - - ! ###################################################################################### - ! - ! SUBROUTINE load_ccpp_scheme_sim_init - ! - ! ###################################################################################### -!! \section arg_table_load_ccpp_scheme_sim_init -!! \htmlinclude load_ccpp_scheme_sim_init.html -!! - subroutine load_ccpp_scheme_sim_init(mpirank, mpiroot, mpicomm, nlunit, nml_file, & - errmsg, errflg) - - ! Inputs - integer, intent (in) :: mpirank, mpiroot, mpicomm, nlunit - character(len=*), intent (in) :: nml_file - - ! Outputs - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Local variables - integer :: ncid, dimID, varID, status, nlon, nlat, ios, iprc, iactive - character(len=256) :: fileIN - logical :: exists - integer,parameter :: nTrc = 1 ! Only specific humodty for now, but preserve 3 dimensionality - - ! Switches for input data - logical :: have_dTdt_LWRAD_data = .false., & - have_dTdt_SWRAD_data = .false., & - have_dTdt_PBL_data = .false., & - have_dqdt_PBL_data = .false., & - have_dudt_PBL_data = .false., & - have_dvdt_PBL_data = .false., & - have_dTdt_GWD_data = .false., & - have_dudt_GWD_data = .false., & - have_dvdt_GWD_data = .false., & - have_dTdt_SCNV_data = .false., & - have_dudt_SCNV_data = .false., & - have_dvdt_SCNV_data = .false., & - have_dqdt_SCNV_data = .false., & - have_dTdt_DCNV_data = .false., & - have_dudt_DCNV_data = .false., & - have_dvdt_DCNV_data = .false., & - have_dqdt_DCNV_data = .false., & - have_dTdt_cldMP_data = .false., & - have_dqdt_cldMP_data = .false. - - ! Namelist - namelist / scm_data_nml / fileIN, nPhysProcess, proc_LWRAD_config, proc_SWRAD_config, & - proc_PBL_config, proc_GWD_config, proc_SCNV_config, proc_DCNV_config, & - proc_cldMP_config - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (module_initialized) return - module_initialized = .true. - - ! ###################################################################################### - ! - ! Part A) Read in namelist and data. - ! - ! ###################################################################################### - - ! Read in namelist - inquire (file = trim (nml_file), exist = exists) - if (.not. exists) then - errmsg = 'SCM data tendency :: namelist file: '//trim(nml_file)//' does not exist' - errflg = 1 - return - else - open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = scm_data_nml, iostat=status) - close (nlunit) - - ! Only proceed if scheme simulator requested. - if (proc_SWRAD_config(1) .or. proc_LWRAD_config(1) .or. proc_PBL_config(1) .or. & - proc_GWD_config(1) .or. proc_SCNV_config(1) .or. proc_DCNV_config(1) .or. & - proc_cldMP_config(1)) then - do_ccpp_scheme_simulator = .true. - else - return - endif - - ! Check that input data file exists - inquire (file = trim (fileIN), exist = exists) - if (.not. exists) then - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not exist' - errflg = 1 - return - endif - - ! Read mandatory information from data file... - ! (ONLY master processor(0), if MPI enabled) -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif - - ! Open file (required) - status = nf90_open(trim(fileIN), NF90_NOWRITE, ncid) - if (status /= nf90_noerr) then - errmsg = 'Error reading in SCM data tendency file: '//trim(fileIN) - errflg = 1 - return - endif - - ! Get dimensions (required) - status = nf90_inq_dimid(ncid, 'time', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [time] dimension' - errflg = 1 - return - endif - ! - status = nf90_inq_dimid(ncid, 'lev', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain [lev] dimension' - errflg = 1 - return - endif -#ifdef MPI - endif ! On master processor - - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - - ! Broadcast dimensions... - ! (ALL processors) - call mpi_bcast(ntime_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_bcast(nlev_data, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - call mpi_barrier(mpicomm, mpierr) - - if (mpirank .eq. mpiroot) then -#endif - - ! - ! What data fields do we have? - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) have_dTdt_LWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) have_dTdt_SWRAD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) have_dTdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) have_dqdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) have_dudt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) have_dvdt_PBL_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) have_dTdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) have_dudt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) have_dvdt_GWD_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) have_dTdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) have_dudt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) have_dvdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) have_dqdt_SCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) have_dTdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) have_dudt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) have_dvdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) have_dqdt_DCNV_data = .true. - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) have_dTdt_cldMP_data = .true. - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) have_dqdt_cldMP_data = .true. - -#ifdef MPI - endif ! Master process -#endif - - ! Allocate space for data - allocate(time_data(ntime_data)) - if (have_dTdt_LWRAD_data) allocate(dTdt_LWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_SWRAD_data) allocate(dTdt_SWRAD_data(nlev_data, ntime_data)) - if (have_dTdt_PBL_data) allocate(dTdt_PBL_data( nlev_data, ntime_data)) - if (have_dqdt_PBL_data) allocate(dqdt_PBL_data( nlev_data, ntime_data)) - if (have_dudt_PBL_data) allocate(dudt_PBL_data( nlev_data, ntime_data)) - if (have_dvdt_PBL_data) allocate(dvdt_PBL_data( nlev_data, ntime_data)) - if (have_dTdt_GWD_data) allocate(dTdt_GWD_data( nlev_data, ntime_data)) - if (have_dudt_GWD_data) allocate(dudt_GWD_data( nlev_data, ntime_data)) - if (have_dvdt_GWD_data) allocate(dvdt_GWD_data( nlev_data, ntime_data)) - if (have_dTdt_SCNV_data) allocate(dTdt_SCNV_data( nlev_data, ntime_data)) - if (have_dudt_SCNV_data) allocate(dudt_SCNV_data( nlev_data, ntime_data)) - if (have_dvdt_SCNV_data) allocate(dvdt_SCNV_data( nlev_data, ntime_data)) - if (have_dqdt_SCNV_data) allocate(dqdt_SCNV_data( nlev_data, ntime_data)) - if (have_dTdt_DCNV_data) allocate(dTdt_DCNV_data( nlev_data, ntime_data)) - if (have_dudt_DCNV_data) allocate(dudt_DCNV_data( nlev_data, ntime_data)) - if (have_dvdt_DCNV_data) allocate(dvdt_DCNV_data( nlev_data, ntime_data)) - if (have_dqdt_DCNV_data) allocate(dqdt_DCNV_data( nlev_data, ntime_data)) - if (have_dTdt_cldMP_data) allocate(dTdt_cldMP_data(nlev_data, ntime_data)) - if (have_dqdt_cldMP_data) allocate(dqdt_cldMP_data(nlev_data, ntime_data)) - - ! Read in data ... - ! (ONLY master processor(0), if MPI enabled) -#ifdef MPI - if (mpirank .eq. mpiroot) then -#endif - - ! Temporal info (required) - status = nf90_inq_varid(ncid, 'times', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, time_data) - else - errmsg = 'SCM data tendency file: '//trim(fileIN)//' does not contain times variable' - errflg = 1 - return - endif - - ! Read in physics data tendencies (optional) - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_LWRAD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SWRAD_data) - print*,'dTdt_SWRAD_data: ',dTdt_SWRAD_data - ! - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_PBL_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_GWD_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_SCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dudt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dvdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_DCNV_data) - ! - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dTdt_cldMP_data) - ! - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, dqdt_cldMP_data) - ! - status = nf90_close(ncid) - -#ifdef MPI - endif ! Master process - - ! Other processors waiting... - call mpi_barrier(mpicomm, mpierr) - - ! Broadcast data... - ! (ALL processors) - if (have_dTdt_LWRAD_data) then - call mpi_bcast(dTdt_LWRAD_data, size(dTdt_LWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SWRAD_data) then - call mpi_bcast(dTdt_SWRAD_data, size(dTdt_SWRAD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_PBL_data) then - call mpi_bcast(dTdt_PBL_data, size(dTdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_PBL_data) then - call mpi_bcast(dqdt_PBL_data, size(dqdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_PBL_data) then - call mpi_bcast(dudt_PBL_data, size(dudt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_PBL_data) then - call mpi_bcast(dvdt_PBL_data, size(dvdt_PBL_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_GWD_data) then - call mpi_bcast(dTdt_GWD_data, size(dTdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_GWD_data) then - call mpi_bcast(dudt_GWD_data, size(dudt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_GWD_data) then - call mpi_bcast(dvdt_GWD_data, size(dvdt_GWD_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_SCNV_data) then - call mpi_bcast(dTdt_SCNV_data, size(dTdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_SCNV_data) then - call mpi_bcast(dudt_SCNV_data, size(dudt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_SCNV_data) then - call mpi_bcast(dvdt_SCNV_data, size(dvdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_SCNV_data) then - call mpi_bcast(dqdt_SCNV_data, size(dqdt_SCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_DCNV_data) then - call mpi_bcast(dTdt_DCNV_data, size(dTdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dudt_DCNV_data) then - call mpi_bcast(dudt_DCNV_data, size(dudt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dvdt_DCNV_data) then - call mpi_bcast(dvdt_DCNV_data, size(dvdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_DCNV_data) then - call mpi_bcast(dqdt_DCNV_data, size(dqdt_DCNV_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dTdt_cldMP_data) then - call mpi_bcast(dTdt_cldMP_data, size(dTdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - if (have_dqdt_cldMP_data) then - call mpi_bcast(dqdt_cldMP_data, size(dqdt_cldMP_data), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - endif - ! - call mpi_barrier(mpicomm, mpierr) -#endif - - ! ####################################################################################### - ! - ! Part B) Populate physics_process type. - ! - ! ####################################################################################### - - ! Allocate - allocate(physics_process(nPhysProcess)) - - ! Metadata - do iprc = 1,nPhysProcess - allocate(physics_process(iprc)%tend1d%T(nlev_data)) - allocate(physics_process(iprc)%tend1d%u(nlev_data)) - allocate(physics_process(iprc)%tend1d%v(nlev_data)) - allocate(physics_process(iprc)%tend1d%q(nlev_data)) - if (iprc == proc_SWRAD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SWRAD" - if (proc_SWRAD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_SWRAD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_LWRAD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "LWRAD" - if (proc_LWRAD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_LWRAD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_GWD_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "GWD" - if (proc_GWD_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_GWD_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_PBL_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "PBL" - if (proc_PBL_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_PBL_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_SCNV_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SCNV" - if (proc_SCNV_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_SCNV_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_DCNV_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "DCNV" - if (proc_DCNV_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_DCNV_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - if (iprc == proc_cldMP_config(3)) then - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "cldMP" - if (proc_cldMP_config(1) == 1) then - physics_process(iprc)%use_sim = .true. - endif - if (proc_cldMP_config(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - endif - enddo - - ! Load data - physics_process(proc_LWRAD_config(3))%tend2d%time => time_data - physics_process(proc_SWRAD_config(3))%tend2d%time => time_data - physics_process(proc_PBL_config(3))%tend2d%time => time_data - physics_process(proc_GWD_config(3))%tend2d%time => time_data - physics_process(proc_DCNV_config(3))%tend2d%time => time_data - physics_process(proc_SCNV_config(3))%tend2d%time => time_data - physics_process(proc_cldMP_config(3))%tend2d%time => time_data - if (have_dTdt_LWRAD_data) physics_process(proc_SWRAD_config(3))%tend2d%T => dTdt_LWRAD_data - if (have_dTdt_SWRAD_data) physics_process(proc_LWRAD_config(3))%tend2d%T => dTdt_SWRAD_data - if (have_dTdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%T => dTdt_PBL_data - if (have_dudt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%u => dudt_PBL_data - if (have_dvdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%v => dvdt_PBL_data - if (have_dqdt_PBL_data) physics_process(proc_PBL_config(3))%tend2d%q => dqdt_PBL_data - if (have_dTdt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%T => dTdt_GWD_data - if (have_dudt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%u => dudt_GWD_data - if (have_dvdt_GWD_data) physics_process(proc_GWD_config(3))%tend2d%v => dvdt_GWD_data - if (have_dTdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%T => dTdt_SCNV_data - if (have_dudt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%u => dudt_SCNV_data - if (have_dvdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%v => dvdt_SCNV_data - if (have_dqdt_SCNV_data) physics_process(proc_SCNV_config(3))%tend2d%q => dqdt_SCNV_data - if (have_dTdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%T => dTdt_DCNV_data - if (have_dudt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%u => dudt_DCNV_data - if (have_dvdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%v => dvdt_DCNV_data - if (have_dqdt_DCNV_data) physics_process(proc_DCNV_config(3))%tend2d%q => dqdt_DCNV_data - if (have_dTdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%T => dTdt_cldMP_data - if (have_dqdt_cldMP_data) physics_process(proc_cldMP_config(3))%tend2d%q => dqdt_cldMP_data - - ! How many active schemes are there? - nactive_proc = 0 - iactive = 0 - do iprc = 1,nPhysProcess - if (.not. physics_process(iprc)%use_sim) nactive_proc = nactive_proc + 1 - enddo - allocate(iactive_scheme(nactive_proc),active_name(nactive_proc),active_time_split_process(nactive_proc)) - - ! Which process-scheme(s) is(are) "Active"? Are they time-split process? - active_time_split_process(:) = .false. - do iprc = 1,nPhysProcess - if (.not. physics_process(iprc)%use_sim) then - iactive = iactive + 1 - iactive_scheme(iactive) = iprc - active_name(iactive) = physics_process(iprc)%name - if (physics_process(iprc)%time_split) then - active_time_split_process(iactive) = .true. - endif - endif - enddo - - ! - if (mpirank .eq. mpiroot) then - print*, "-----------------------------------" - print*, "--- Using CCPP scheme simulator ---" - print*, "-----------------------------------" - iactive = 1 - do iprc = 1,nPhysProcess - if (physics_process(iprc)%use_sim) then - print*," simulate_scheme: ", trim(physics_process(iprc)%name) - print*," order: ", physics_process(iprc)%order - print*," time_split: ", physics_process(iprc)%time_split - else - print*, " active_scheme: ", trim(active_name(iactive)) - print*, " order: ", physics_process(iactive_scheme(iactive))%order - print*, " time_split : ", active_time_split_process(iactive) - iactive = iactive + 1 - endif - enddo - print*, "-----------------------------------" - print*, "-----------------------------------" - endif - - end subroutine load_ccpp_scheme_sim_init - -end module load_ccpp_scheme_sim diff --git a/physics/load_ccpp_scheme_sim.meta b/physics/load_ccpp_scheme_sim.meta deleted file mode 100644 index 6e0aea925..000000000 --- a/physics/load_ccpp_scheme_sim.meta +++ /dev/null @@ -1,60 +0,0 @@ -[ccpp-table-properties] - name = load_ccpp_scheme_sim - type = scheme - dependencies = machine.F,ccpp_scheme_simulator.F90 - -######################################################################## -[ccpp-arg-table] - name = load_ccpp_scheme_sim_init - type = scheme -[mpirank] - standard_name = mpi_rank - long_name = MPI rank of current process - units = index - dimensions = () - type = integer - intent = in -[mpiroot] - standard_name = mpi_root - long_name = MPI rank of master process - units = index - dimensions = () - type = integer - intent = in -[mpicomm] - standard_name = mpi_communicator - long_name = MPI communicator - units = index - dimensions = () - type = integer - intent = in -[nlunit] - standard_name = iounit_of_namelist - long_name = fortran unit number for opening nameliust file - units = none - dimensions = () - type = integer - intent = in -[nml_file] - standard_name = filename_of_namelist - long_name = namelist filename - units = none - dimensions = () - type = character - kind = len=* - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out diff --git a/physics/module_ccpp_scheme_simulator.F90 b/physics/module_ccpp_scheme_simulator.F90 index a0756ab61..695a2bb03 100644 --- a/physics/module_ccpp_scheme_simulator.F90 +++ b/physics/module_ccpp_scheme_simulator.F90 @@ -15,41 +15,45 @@ module module_ccpp_scheme_simulator ! Type containing 1D (time) physics tendencies. type phys_tend_1d - real(kind_phys), dimension(:), pointer :: T - real(kind_phys), dimension(:), pointer :: u - real(kind_phys), dimension(:), pointer :: v - real(kind_phys), dimension(:), pointer :: q + real(kind_phys), dimension(:), allocatable :: T + real(kind_phys), dimension(:), allocatable :: u + real(kind_phys), dimension(:), allocatable :: v + real(kind_phys), dimension(:), allocatable :: q + real(kind_phys), dimension(:), allocatable :: p + real(kind_phys), dimension(:), allocatable :: z end type phys_tend_1d ! Type containing 2D (lev,time) physics tendencies. type phys_tend_2d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: T - real(kind_phys), dimension(:,:), pointer :: u - real(kind_phys), dimension(:,:), pointer :: v - real(kind_phys), dimension(:,:), pointer :: q + real(kind_phys), dimension(:), allocatable :: time + real(kind_phys), dimension(:,:), allocatable :: T + real(kind_phys), dimension(:,:), allocatable :: u + real(kind_phys), dimension(:,:), allocatable :: v + real(kind_phys), dimension(:,:), allocatable :: q + real(kind_phys), dimension(:,:), allocatable :: p + real(kind_phys), dimension(:,:), allocatable :: z end type phys_tend_2d ! Type containing 3D (loc,lev,time) physics tendencies. type phys_tend_3d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:), pointer :: lon - real(kind_phys), dimension(:), pointer :: lat - real(kind_phys), dimension(:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:), pointer :: q + real(kind_phys), dimension(:), allocatable :: time + real(kind_phys), dimension(:), allocatable :: lon + real(kind_phys), dimension(:), allocatable :: lat + real(kind_phys), dimension(:,:,:), allocatable :: T + real(kind_phys), dimension(:,:,:), allocatable :: u + real(kind_phys), dimension(:,:,:), allocatable :: v + real(kind_phys), dimension(:,:,:), allocatable :: q end type phys_tend_3d - ! Type containing 4D (lon, lat,lev,time) physics tendencies. + ! Type containing 4D (lon,lat,lev,time) physics tendencies. type phys_tend_4d - real(kind_phys), dimension(:), pointer :: time - real(kind_phys), dimension(:,:), pointer :: lon - real(kind_phys), dimension(:,:), pointer :: lat - real(kind_phys), dimension(:,:,:,:), pointer :: T - real(kind_phys), dimension(:,:,:,:), pointer :: u - real(kind_phys), dimension(:,:,:,:), pointer :: v - real(kind_phys), dimension(:,:,:,:), pointer :: q + real(kind_phys), dimension(:), allocatable :: time + real(kind_phys), dimension(:,:), allocatable :: lon + real(kind_phys), dimension(:,:), allocatable :: lat + real(kind_phys), dimension(:,:,:,:), allocatable :: T + real(kind_phys), dimension(:,:,:,:), allocatable :: u + real(kind_phys), dimension(:,:,:,:), allocatable :: v + real(kind_phys), dimension(:,:,:,:), allocatable :: q end type phys_tend_4d ! This type contains the meta information and data for each physics process. @@ -58,14 +62,17 @@ module module_ccpp_scheme_simulator !! \htmlinclude base_physics_process.html !! type base_physics_process - character(len=16) :: name - logical :: time_split = .false. - logical :: use_sim = .false. - integer :: order - type(phys_tend_1d) :: tend1d - type(phys_tend_2d) :: tend2d - type(phys_tend_3d) :: tend3d - type(phys_tend_4d) :: tend4d + character(len=16) :: name ! Physics process name + logical :: time_split = .false. ! Is process time-split? + logical :: use_sim = .false. ! Is process "active"? + integer :: order ! Order of process in process-loop + type(phys_tend_1d) :: tend1d ! Instantaneous data + type(phys_tend_2d) :: tend2d ! 2-dimensional data + type(phys_tend_3d) :: tend3d ! Not used. Placeholder for 3-dimensional spatial data. + type(phys_tend_4d) :: tend4d ! Not used. Placeholder for 4-dimensional spatio-tempo data. + character(len=16) :: active_name ! "Active" scheme: Physics process name + integer :: iactive_scheme ! "Active" scheme: Order of process in process-loop + logical :: active_tsp ! "Active" scheme: Is process time-split? contains generic, public :: linterp => linterp_1D, linterp_2D procedure, private :: linterp_1D @@ -109,7 +116,7 @@ end function linterp_1D ! Type-bound procedure to compute tendency profile for time-of-day. ! ! For use with 2D data (location, level, time) tendencies with diurnal (24-hr) forcing. - ! This assumes that the location dimension has a [longitude, latitude] associated with + ! This assumes that the location dimension has a [longitude, latitude] allocated with ! each location. ! #################################################################################### function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) result(err_message) @@ -180,7 +187,7 @@ subroutine sim_LWRAD( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif @@ -193,7 +200,7 @@ subroutine sim_SWRAD( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif @@ -206,13 +213,13 @@ subroutine sim_GWD( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%u)) then + if (allocated(process%tend2d%u)) then errmsg = process%linterp("u", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%v)) then + if (allocated(process%tend2d%v)) then errmsg = process%linterp("v", year,month,day,hour,min,sec) endif @@ -225,16 +232,16 @@ subroutine sim_PBL( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%u)) then + if (allocated(process%tend2d%u)) then errmsg = process%linterp("u", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%v)) then + if (allocated(process%tend2d%v)) then errmsg = process%linterp("v", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%q)) then + if (allocated(process%tend2d%q)) then errmsg = process%linterp("q", year,month,day,hour,min,sec) endif @@ -247,16 +254,16 @@ subroutine sim_DCNV( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%u)) then + if (allocated(process%tend2d%u)) then errmsg = process%linterp("u", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%v)) then + if (allocated(process%tend2d%v)) then errmsg = process%linterp("v", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%q)) then + if (allocated(process%tend2d%q)) then errmsg = process%linterp("q", year,month,day,hour,min,sec) endif @@ -269,16 +276,16 @@ subroutine sim_SCNV( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%u)) then + if (allocated(process%tend2d%u)) then errmsg = process%linterp("u", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%v)) then + if (allocated(process%tend2d%v)) then errmsg = process%linterp("v", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%q)) then + if (allocated(process%tend2d%q)) then errmsg = process%linterp("q", year,month,day,hour,min,sec) endif @@ -291,10 +298,10 @@ subroutine sim_cldMP( year, month, day, hour, min, sec, process) integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: errmsg - if (associated(process%tend2d%T)) then + if (allocated(process%tend2d%T)) then errmsg = process%linterp("T", year,month,day,hour,min,sec) endif - if (associated(process%tend2d%q)) then + if (allocated(process%tend2d%q)) then errmsg = process%linterp("q", year,month,day,hour,min,sec) endif end subroutine sim_cldMP From 4d691081e46d17d5b77b6aa7714ba2a369088ae4 Mon Sep 17 00:00:00 2001 From: Grant Firl Date: Wed, 14 Jun 2023 14:25:38 -0400 Subject: [PATCH 22/64] fix bug in scm_sfc_flux_spec.F90 --- physics/scm_sfc_flux_spec.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index 835b468ff..e835b77ff 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -58,9 +58,9 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, use machine, only: kind_phys integer, intent(in) :: im, lkm - integer, intent(inout) :: islmsk(:) + integer, intent(inout) :: islmsk(:), use_lake_model(:) logical, intent(in) :: cplflx, cplice - logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_lake_model(:) + logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:) real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) From 12d4fc22128d7267fb6a8563a94bb579d27d2127 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Fri, 7 Jul 2023 12:16:54 -0600 Subject: [PATCH 23/64] Working as expected! --- physics/GFS_ccpp_scheme_sim_pre.F90 | 77 ++++++++++++++++++------ physics/GFS_ccpp_scheme_sim_pre.meta | 28 +++++++++ physics/ccpp_scheme_simulator.F90 | 47 ++++++++++----- physics/ccpp_scheme_simulator.meta | 28 +++++++++ physics/module_ccpp_scheme_simulator.F90 | 1 + 5 files changed, 150 insertions(+), 31 deletions(-) diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 index 31bafff01..a5f6f0cfa 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -24,8 +24,8 @@ module GFS_ccpp_scheme_sim_pre subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process_dcnv, & index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, & - physics_process, active_phys_tend, errmsg, errflg) + index_of_temperature, index_of_x_wind, index_of_y_wind, physics_process, & + iactive_T, iactive_u, iactive_v, iactive_q, active_phys_tend, errmsg, errflg) ! Inputs integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & @@ -36,6 +36,7 @@ subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process real(kind_phys), intent(in) :: dtp real(kind_phys), intent(in), dimension(:,:,:) :: dtend type(base_physics_process),intent(in) :: physics_process(:) + integer, intent(in) :: iactive_T, iactive_u, iactive_v, iactive_q ! Outputs real(kind_phys), intent(out) :: active_phys_tend(:,:,:) @@ -76,23 +77,33 @@ subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process ! Heat idtend = dtidx(index_of_temperature,iactive) - if (idtend >= 1) active_phys_tend(:,:,1) = dtend(:,:,idtend)/dtp + if (idtend >= 1) then + active_phys_tend(:,:,iactive_T) = dtend(:,:,idtend)/dtp + endif + ! u-wind idtend = dtidx(index_of_x_wind,iactive) - if (idtend >= 1) active_phys_tend(:,:,2) = dtend(:,:,idtend)/dtp + if (idtend >= 1) then + active_phys_tend(:,:,iactive_u) = dtend(:,:,idtend)/dtp + endif + ! v-wind idtend = dtidx(index_of_y_wind,iactive) - if (idtend >= 1) active_phys_tend(:,:,3) = dtend(:,:,idtend)/dtp + if (idtend >= 1) then + active_phys_tend(:,:,iactive_v) = dtend(:,:,idtend)/dtp + endif + ! Moisture idtend = dtidx(100+ntqv,iactive) - if (idtend >= 1) active_phys_tend(:,:,4) = dtend(:,:,idtend)/dtp - + if (idtend >= 1) then + active_phys_tend(:,:,iactive_q) = dtend(:,:,idtend)/dtp + endif end subroutine GFS_ccpp_scheme_sim_pre_run ! ###################################################################################### - subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, & - errmsg, errflg) + subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, & + iactive_T, iactive_u, iactive_v, iactive_q, errmsg, errflg) ! Inputs integer, intent (in) :: nlunit @@ -100,7 +111,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, ! Outputs type(base_physics_process),intent(inout),allocatable :: physics_process(:) - integer, intent(out) :: nprg_active + integer, intent(inout) :: iactive_T, iactive_u, iactive_v, iactive_q integer, intent(out) :: errflg character(len=256), intent(out) :: errmsg @@ -221,14 +232,17 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "SWRAD" if (prc_SWRAD_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 1 + iactive_T = 1 endif if (prc_SWRAD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - nprg_active = 1 endif if (iprc == prc_LWRAD_cfg(3)) then @@ -237,14 +251,17 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "LWRAD" if (prc_LWRAD_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 1 + iactive_T = 1 endif if (prc_LWRAD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - nprg_active =1 endif if (iprc == prc_GWD_cfg(3)) then @@ -253,10 +270,16 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "GWD" if (prc_GWD_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 3 + iactive_T = 1 + iactive_u = 2 + iactive_v = 3 endif if (prc_GWD_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) @@ -264,7 +287,6 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - nprg_active = 3 endif if (iprc == prc_PBL_cfg(3)) then @@ -273,10 +295,17 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "PBL" if (prc_PBL_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 4 + iactive_T = 1 + iactive_u = 2 + iactive_v = 3 + iactive_q = 4 endif if (prc_PBL_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) @@ -286,7 +315,6 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - nprg_active = 4 endif if (iprc == prc_SCNV_cfg(3)) then @@ -295,10 +323,17 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "SCNV" if (prc_SCNV_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 4 + iactive_T = 1 + iactive_u = 2 + iactive_v = 3 + iactive_q = 4 endif if (prc_SCNV_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) @@ -308,7 +343,6 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - nprg_active = 4 endif if (iprc == prc_DCNV_cfg(3)) then @@ -317,6 +351,12 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "DCNV" if (prc_DCNV_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 4 + iactive_T = 1 + iactive_u = 2 + iactive_v = 3 + iactive_q = 4 endif if (prc_DCNV_cfg(2) == 1) then physics_process(iprc)%time_split = .true. @@ -330,7 +370,6 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - nprg_active = 4 endif if (iprc == prc_cldMP_cfg(3)) then @@ -339,16 +378,20 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, nprg_active, physics_process(iprc)%name = "cldMP" if (prc_cldMP_cfg(1) == 1) then physics_process(iprc)%use_sim = .true. + else + physics_process(1)%nprg_active = 2 + iactive_T = 1 + iactive_q = 2 endif if (prc_cldMP_cfg(2) == 1) then physics_process(iprc)%time_split = .true. endif + ! Data status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - nprg_active = 2 endif ! Which process-scheme is "active"? Is process time-split? diff --git a/physics/GFS_ccpp_scheme_sim_pre.meta b/physics/GFS_ccpp_scheme_sim_pre.meta index e101e4650..682b4baf8 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.meta +++ b/physics/GFS_ccpp_scheme_sim_pre.meta @@ -122,6 +122,34 @@ type = real kind = kind_phys intent = out +[iactive_T] + standard_name = index_for_active_T_in_CCPP_scheme_simulator + long_name = index into active process tracer array for temperature in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_u] + standard_name = index_for_active_u_in_CCPP_scheme_simulator + long_name = index into active process tracer array for zonal wind in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_v] + standard_name = index_for_active_v_in_CCPP_scheme_simulator + long_name = index into active process tracer array for meridional wind in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_q] + standard_name = index_for_active_q_in_CCPP_scheme_simulator + long_name = index into active process tracer array for moisture in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index e4348599f..b825b8403 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -7,7 +7,7 @@ ! ######################################################################################## module ccpp_scheme_simulator use machine, only: kind_phys - use module_ccpp_scheme_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & + use module_ccpp_scheme_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & sim_PBL, sim_GWD, sim_DCNV, sim_SCNV, sim_cldMP implicit none public ccpp_scheme_simulator_run @@ -22,15 +22,16 @@ module ccpp_scheme_simulator !! \htmlinclude ccpp_scheme_simulator_run.html !! subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, jdat, & - proc_start, proc_end, physics_process, in_pre_active, in_post_active, tgrs, ugrs, & - vgrs, qgrs, active_phys_tend, gt0, gu0, gv0, gq0, errmsg, errflg) + iactive_T, iactive_u, iactive_v, iactive_q, proc_start, proc_end, physics_process,& + in_pre_active, in_post_active, tgrs, ugrs, vgrs, qgrs, active_phys_tend, gt0, gu0,& + gv0, gq0, errmsg, errflg) ! Inputs logical, intent(in) :: do_ccpp_scheme_sim - integer, intent(in) :: kdt, nCol, nLay, jdat(8) + integer, intent(in) :: kdt, nCol, nLay, jdat(8), iactive_T, iactive_u, & + iactive_v, iactive_q real(kind_phys), intent(in) :: dtp, tgrs(:,:), ugrs(:,:), vgrs(:,:), qgrs(:,:,:), & active_phys_tend(:,:,:) - ! Outputs type(base_physics_process),intent(inout) :: physics_process(:) real(kind_phys), intent(inout) :: gt0(:,:), gu0(:,:), gv0(:,:), gq0(:,:) @@ -125,18 +126,18 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j ! Using data tendency from "active" scheme(s). else - physics_process(iprc)%tend1d%T = active_phys_tend(iCol,:,1) - physics_process(iprc)%tend1d%u = active_phys_tend(iCol,:,2) - physics_process(iprc)%tend1d%v = active_phys_tend(iCol,:,3) - physics_process(iprc)%tend1d%q = active_phys_tend(iCol,:,4) + if (iactive_T > 0) physics_process(iprc)%tend1d%T = active_phys_tend(iCol,:,iactive_T) + if (iactive_u > 0) physics_process(iprc)%tend1d%u = active_phys_tend(iCol,:,iactive_u) + if (iactive_v > 0) physics_process(iprc)%tend1d%v = active_phys_tend(iCol,:,iactive_v) + if (iactive_q > 0) physics_process(iprc)%tend1d%q = active_phys_tend(iCol,:,iactive_q) endif ! Update state now? (time-split scheme) if (physics_process(iprc)%time_split) then - gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp - gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp - gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp - gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp + gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp + gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp + gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp + gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp dTdt(iCol,:) = 0. dudt(iCol,:) = 0. dvdt(iCol,:) = 0. @@ -149,11 +150,29 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q endif enddo ! END: Loop over columns + + ! Print diagnostics + if (physics_process(iprc)%use_sim) then + if (physics_process(iprc)%time_split) then + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'time split scheme (simulated)' + else + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'process split scheme (simulated)' + endif + else + if (physics_process(iprc)%time_split) then + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,' time split scheme (active)' + else + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,' process split scheme (active)' + endif + write(*,'(a25,i2)') ' # prog. vars.: ',physics_process(1)%nprg_active + endif enddo ! END: Loop over physics processes ! ! Update state with accumulated tendencies (process-split only) + ! (Suites where active scheme is last physical process) ! + iprc = minval([iprc,proc_end]) if (.not. physics_process(iprc)%time_split) then do iCol = 1,nCol gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp @@ -171,7 +190,7 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j in_post_active = .true. endif - if (size(physics_process)+1 == iprc) then + if (size(physics_process) == proc_end) then in_pre_active = .true. in_post_active = .false. endif diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_scheme_simulator.meta index 8b2618317..c60cd9a38 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_scheme_simulator.meta @@ -117,6 +117,34 @@ type = real kind = kind_phys intent = in +[iactive_T] + standard_name = index_for_active_T_in_CCPP_scheme_simulator + long_name = index into active process tracer array for temperature in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_u] + standard_name = index_for_active_u_in_CCPP_scheme_simulator + long_name = index into active process tracer array for zonal wind in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_v] + standard_name = index_for_active_v_in_CCPP_scheme_simulator + long_name = index into active process tracer array for meridional wind in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in +[iactive_q] + standard_name = index_for_active_q_in_CCPP_scheme_simulator + long_name = index into active process tracer array for moisture in CCPP scheme simulator + units = count + dimensions = () + type = integer + intent = in [gt0] standard_name = air_temperature_of_new_state long_name = temperature updated by physics diff --git a/physics/module_ccpp_scheme_simulator.F90 b/physics/module_ccpp_scheme_simulator.F90 index 695a2bb03..a122563d9 100644 --- a/physics/module_ccpp_scheme_simulator.F90 +++ b/physics/module_ccpp_scheme_simulator.F90 @@ -73,6 +73,7 @@ module module_ccpp_scheme_simulator character(len=16) :: active_name ! "Active" scheme: Physics process name integer :: iactive_scheme ! "Active" scheme: Order of process in process-loop logical :: active_tsp ! "Active" scheme: Is process time-split? + integer :: nprg_active ! "Active" scheme: Number of prognostic variables contains generic, public :: linterp => linterp_1D, linterp_2D procedure, private :: linterp_1D From 9465b6f1a63606cf3ae4c0d48feab0507f338be4 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Tue, 11 Jul 2023 14:48:26 -0600 Subject: [PATCH 24/64] Housekeeping --- physics/GFS_ccpp_scheme_sim_pre.F90 | 21 +++++++++++++-------- physics/ccpp_scheme_simulator.F90 | 22 +++++++++++++++++----- 2 files changed, 30 insertions(+), 13 deletions(-) diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 index a5f6f0cfa..61ab573a3 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -1,8 +1,12 @@ ! ######################################################################################## ! -! Interstitial CCPP scheme to couple UFS physics to ccpp_scheme_simulator. -! ) load: read and load data into type used by ccpp_scheme_simulator -! ) _run: prepare GFS diagnostic physics tendencies for ccpp_scheme_simulator +! Description: Interstitial CCPP scheme to couple UFS physics to ccpp_scheme_simulator. +! +! Contains: +! - load_ccpp_scheme_sim(): read and load data into type used by ccpp_scheme_simulator. +! called once during model initialization +! - GFS_ccpp_scheme_sim_pre_run(): prepare GFS diagnostic physics tendencies for +! ccpp_scheme_simulator. ! ! ######################################################################################## module GFS_ccpp_scheme_sim_pre @@ -102,8 +106,8 @@ subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process end subroutine GFS_ccpp_scheme_sim_pre_run ! ###################################################################################### - subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, & - iactive_T, iactive_u, iactive_v, iactive_q, errmsg, errflg) + subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, & + iactive_u, iactive_v, iactive_q, errmsg, errflg) ! Inputs integer, intent (in) :: nlunit @@ -121,7 +125,8 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, & logical :: exists, do_ccpp_scheme_sim integer :: nprc_sim - ! For each process there is a corresponding namelist entry, which is constructed as follows: + ! For each process there is a corresponding namelist entry, which is constructed as + ! follows: ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} integer, dimension(3) :: & prc_LWRAD_cfg = (/0,0,0/), & @@ -133,8 +138,8 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, & prc_cldMP_cfg = (/0,0,0/) ! Namelist - namelist / ccpp_scheme_sim_nml / do_ccpp_scheme_sim, scheme_sim_file, nprc_sim, & - prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, prc_GWD_cfg, prc_SCNV_cfg, & + namelist / ccpp_scheme_sim_nml / do_ccpp_scheme_sim, scheme_sim_file, nprc_sim, & + prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, prc_GWD_cfg, prc_SCNV_cfg, & prc_DCNV_cfg, prc_cldMP_cfg errmsg = '' diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_scheme_simulator.F90 index b825b8403..f3a6372ac 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_scheme_simulator.F90 @@ -1,8 +1,20 @@ ! ######################################################################################## -! -! CCPP scheme to replace physics schemes with simulated data tendencies. ! -! Description: +! Description: This scheme simulates the evolution of the internal physics state +! represented by a CCPP Suite Definition File (SDF). +! +! To activate this scheme it must be a) embedded within the SDF and b) activated through +! the physics namelist. +! The derived-data type "base_physics_process" contains the metadata needed to reconstruct +! the temporal evolution of the state. An array of base_physics_process, physics_process, +! is populated by the host during initialization and passed to the physics. Additionally, +! this type holds any data, or type-bound procedures, required by the scheme simulator(s). +! +! For this initial demonstration we are using 2-dimensional (height, time) forcing data, +! which is on the same native vertical grid as the SCM. The dataset has a temporal +! resolution of 1-hour, created by averaging all local times from a Tropical Warm Pool +! International Cloud Experiment (TWPICE) case. This was to create a dataset with a +! (constant) diurnal cycle. ! ! ######################################################################################## module ccpp_scheme_simulator @@ -160,9 +172,9 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j endif else if (physics_process(iprc)%time_split) then - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,' time split scheme (active)' + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'time split scheme (active)' else - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,' process split scheme (active)' + write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'process split scheme (active)' endif write(*,'(a25,i2)') ' # prog. vars.: ',physics_process(1)%nprg_active endif From c61a2a61e7493c4b3dccae26761bdbd4f1939c5b Mon Sep 17 00:00:00 2001 From: dustinswales Date: Thu, 13 Jul 2023 11:01:50 -0600 Subject: [PATCH 25/64] GNU bug found in SCM CI --- physics/GFS_ccpp_scheme_sim_pre.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 index 61ab573a3..db80e0c84 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -159,9 +159,9 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, close (nlunit) ! Only proceed if scheme simulator requested. - if (prc_SWRAD_cfg(1) .or. prc_LWRAD_cfg(1) .or. prc_PBL_cfg(1) .or. & - prc_GWD_cfg(1) .or. prc_SCNV_cfg(1) .or. prc_DCNV_cfg(1) .or. & - prc_cldMP_cfg(1)) then + if (prc_SWRAD_cfg(1) == 1 .or. prc_LWRAD_cfg(1) == 1 .or. prc_PBL_cfg(1) == 1 .or. & + prc_GWD_cfg(1) == 1 .or. prc_SCNV_cfg(1) == 1 .or. prc_DCNV_cfg(1) == 1 .or. & + prc_cldMP_cfg(1) == 1 ) then else return endif From 8e5646e91dc31ac88baf4905eeb3056578b8aa9e Mon Sep 17 00:00:00 2001 From: dustinswales Date: Mon, 17 Jul 2023 18:08:45 -0600 Subject: [PATCH 26/64] Some cleanup. --- physics/GFS_ccpp_scheme_sim_pre.F90 | 14 +++++++++----- physics/GFS_ccpp_scheme_sim_pre.meta | 7 +++++++ 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_scheme_sim_pre.F90 index db80e0c84..47865353d 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_scheme_sim_pre.F90 @@ -25,13 +25,15 @@ module GFS_ccpp_scheme_sim_pre !! \section arg_table_GFS_ccpp_scheme_sim_pre_run !! \htmlinclude GFS_ccpp_scheme_sim_pre_run.html !! - subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process_dcnv, & - index_of_process_longwave, index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind, physics_process, & - iactive_T, iactive_u, iactive_v, iactive_q, active_phys_tend, errmsg, errflg) + subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, dtp, & + index_of_process_dcnv, index_of_process_longwave, index_of_process_shortwave, & + index_of_process_scnv, index_of_process_orographic_gwd, index_of_process_pbl, & + index_of_process_mp, index_of_temperature, index_of_x_wind, index_of_y_wind, & + physics_process, iactive_T, iactive_u, iactive_v, iactive_q, active_phys_tend, & + errmsg, errflg) ! Inputs + logical, intent(in) :: do_ccpp_scheme_sim integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & @@ -54,6 +56,8 @@ subroutine GFS_ccpp_scheme_sim_pre_run(dtend, ntqv, dtidx, dtp, index_of_process errmsg = '' errflg = 0 + if (.not. do_ccpp_scheme_sim) return + ! Get tendency for "active" process. ! ###################################################################################### diff --git a/physics/GFS_ccpp_scheme_sim_pre.meta b/physics/GFS_ccpp_scheme_sim_pre.meta index 682b4baf8..ca6d4f7cc 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.meta +++ b/physics/GFS_ccpp_scheme_sim_pre.meta @@ -7,6 +7,13 @@ [ccpp-arg-table] name = GFS_ccpp_scheme_sim_pre_run type = scheme +[do_ccpp_scheme_sim] + standard_name = flag_for_ccpp_scheme_simulator + long_name = flag for ccpp scheme simulator + units = flag + dimensions = () + type = logical + intent = in [physics_process] standard_name = physics_process_type_for_CCPP_scheme_simulator long_name = physics process type for CCPP scheme simulator From e3c00d35207299024be4b016a2db8c3ad40f3ea7 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 19 Jul 2023 11:53:00 -0600 Subject: [PATCH 27/64] Renamed scheme simulator suite simulator --- ...sim_pre.F90 => GFS_ccpp_suite_sim_pre.F90} | 74 +++++++++---------- ...m_pre.meta => GFS_ccpp_suite_sim_pre.meta} | 40 +++++----- ...simulator.F90 => ccpp_suite_simulator.F90} | 28 +++---- ...mulator.meta => ccpp_suite_simulator.meta} | 56 +++++++------- ...or.F90 => module_ccpp_suite_simulator.F90} | 10 +-- ....meta => module_ccpp_suite_simulator.meta} | 4 +- 6 files changed, 106 insertions(+), 106 deletions(-) rename physics/{GFS_ccpp_scheme_sim_pre.F90 => GFS_ccpp_suite_sim_pre.F90} (86%) rename physics/{GFS_ccpp_scheme_sim_pre.meta => GFS_ccpp_suite_sim_pre.meta} (83%) rename physics/{ccpp_scheme_simulator.F90 => ccpp_suite_simulator.F90} (91%) rename physics/{ccpp_scheme_simulator.meta => ccpp_suite_simulator.meta} (76%) rename physics/{module_ccpp_scheme_simulator.F90 => module_ccpp_suite_simulator.F90} (98%) rename physics/{module_ccpp_scheme_simulator.meta => module_ccpp_suite_simulator.meta} (86%) diff --git a/physics/GFS_ccpp_scheme_sim_pre.F90 b/physics/GFS_ccpp_suite_sim_pre.F90 similarity index 86% rename from physics/GFS_ccpp_scheme_sim_pre.F90 rename to physics/GFS_ccpp_suite_sim_pre.F90 index 47865353d..fbaf5a1d9 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.F90 +++ b/physics/GFS_ccpp_suite_sim_pre.F90 @@ -1,31 +1,31 @@ ! ######################################################################################## ! -! Description: Interstitial CCPP scheme to couple UFS physics to ccpp_scheme_simulator. +! Description: Interstitial CCPP suite to couple UFS physics to ccpp_suite_simulator. ! ! Contains: -! - load_ccpp_scheme_sim(): read and load data into type used by ccpp_scheme_simulator. +! - load_ccpp_suite_sim(): read and load data into type used by ccpp_suite_simulator. ! called once during model initialization -! - GFS_ccpp_scheme_sim_pre_run(): prepare GFS diagnostic physics tendencies for -! ccpp_scheme_simulator. +! - GFS_ccpp_suite_sim_pre_run(): prepare GFS diagnostic physics tendencies for +! ccpp_suite_simulator. ! ! ######################################################################################## -module GFS_ccpp_scheme_sim_pre +module GFS_ccpp_suite_sim_pre use machine, only: kind_phys - use module_ccpp_scheme_simulator, only: base_physics_process + use module_ccpp_suite_simulator, only: base_physics_process use netcdf implicit none - public GFS_ccpp_scheme_sim_pre_run, load_ccpp_scheme_sim + public GFS_ccpp_suite_sim_pre_run, load_ccpp_suite_sim contains ! ###################################################################################### ! - ! SUBROUTINE GFS_ccpp_scheme_sim_pre_run + ! SUBROUTINE GFS_ccpp_suite_sim_pre_run ! ! ###################################################################################### -!! \section arg_table_GFS_ccpp_scheme_sim_pre_run -!! \htmlinclude GFS_ccpp_scheme_sim_pre_run.html +!! \section arg_table_GFS_ccpp_suite_sim_pre_run +!! \htmlinclude GFS_ccpp_suite_sim_pre_run.html !! - subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, dtp, & + subroutine GFS_ccpp_suite_sim_pre_run(do_ccpp_suite_sim, dtend, ntqv, dtidx, dtp, & index_of_process_dcnv, index_of_process_longwave, index_of_process_shortwave, & index_of_process_scnv, index_of_process_orographic_gwd, index_of_process_pbl, & index_of_process_mp, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -33,7 +33,7 @@ subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, d errmsg, errflg) ! Inputs - logical, intent(in) :: do_ccpp_scheme_sim + logical, intent(in) :: do_ccpp_suite_sim integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & index_of_process_shortwave, index_of_process_scnv, & index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & @@ -56,7 +56,7 @@ subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, d errmsg = '' errflg = 0 - if (.not. do_ccpp_scheme_sim) return + if (.not. do_ccpp_suite_sim) return ! Get tendency for "active" process. @@ -64,7 +64,7 @@ subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, d ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional ! array, CCPP standard_name = cumulative_change_of_state_variables. ! These are not the instantaneous physics tendencies that are applied to the state by - ! the physics schemes. Not all schemes output physics tendencies... + ! the physics suites. Not all suites output physics tendencies... ! Rather these are intended for diagnostic puposes and are accumulated over some ! interval. ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option @@ -107,10 +107,10 @@ subroutine GFS_ccpp_scheme_sim_pre_run(do_ccpp_scheme_sim, dtend, ntqv, dtidx, d active_phys_tend(:,:,iactive_q) = dtend(:,:,idtend)/dtp endif - end subroutine GFS_ccpp_scheme_sim_pre_run + end subroutine GFS_ccpp_suite_sim_pre_run ! ###################################################################################### - subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, & + subroutine load_ccpp_suite_sim(nlunit, nml_file, physics_process, iactive_T, & iactive_u, iactive_v, iactive_q, errmsg, errflg) ! Inputs @@ -125,13 +125,13 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, ! Local variables integer :: ncid, dimID, varID, status, ios, iprc, nlev_data, ntime_data - character(len=256) :: scheme_sim_file - logical :: exists, do_ccpp_scheme_sim + character(len=256) :: suite_sim_file + logical :: exists, do_ccpp_suite_sim integer :: nprc_sim ! For each process there is a corresponding namelist entry, which is constructed as ! follows: - ! {use_scheme_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} + ! {use_suite_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} integer, dimension(3) :: & prc_LWRAD_cfg = (/0,0,0/), & prc_SWRAD_cfg = (/0,0,0/), & @@ -142,7 +142,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, prc_cldMP_cfg = (/0,0,0/) ! Namelist - namelist / ccpp_scheme_sim_nml / do_ccpp_scheme_sim, scheme_sim_file, nprc_sim, & + namelist / ccpp_suite_sim_nml / do_ccpp_suite_sim, suite_sim_file, nprc_sim, & prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, prc_GWD_cfg, prc_SCNV_cfg, & prc_DCNV_cfg, prc_cldMP_cfg @@ -152,17 +152,17 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, ! Read in namelist inquire (file = trim (nml_file), exist = exists) if (.not. exists) then - errmsg = 'CCPP scheme simulator namelist file: '//trim(nml_file)//' does not exist.' + errmsg = 'CCPP suite simulator namelist file: '//trim(nml_file)//' does not exist.' errflg = 1 return else open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) endif rewind (nlunit) - read (nlunit, nml = ccpp_scheme_sim_nml, iostat=status) + read (nlunit, nml = ccpp_suite_sim_nml, iostat=status) close (nlunit) - ! Only proceed if scheme simulator requested. + ! Only proceed if suite simulator requested. if (prc_SWRAD_cfg(1) == 1 .or. prc_LWRAD_cfg(1) == 1 .or. prc_PBL_cfg(1) == 1 .or. & prc_GWD_cfg(1) == 1 .or. prc_SCNV_cfg(1) == 1 .or. prc_DCNV_cfg(1) == 1 .or. & prc_cldMP_cfg(1) == 1 ) then @@ -171,9 +171,9 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, endif ! Check that input data file exists. - inquire (file = trim (scheme_sim_file), exist = exists) + inquire (file = trim (suite_sim_file), exist = exists) if (.not. exists) then - errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not exist' + errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not exist' errflg = 1 return endif @@ -183,9 +183,9 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, ! ! Open file - status = nf90_open(trim(scheme_sim_file), NF90_NOWRITE, ncid) + status = nf90_open(trim(suite_sim_file), NF90_NOWRITE, ncid) if (status /= nf90_noerr) then - errmsg = 'Error reading in CCPP scheme simulator file: '//trim(scheme_sim_file) + errmsg = 'Error reading in CCPP suite simulator file: '//trim(suite_sim_file) errflg = 1 return endif @@ -195,7 +195,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, if (status == nf90_noerr) then status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) else - errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not contain [time] dimension' + errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not contain [time] dimension' errflg = 1 return endif @@ -204,7 +204,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, if (status == nf90_noerr) then status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) else - errmsg = 'CCPP scheme simulator file: '//trim(scheme_sim_file)//' does not contain [lev] dimension' + errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not contain [lev] dimension' errflg = 1 return endif @@ -230,7 +230,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, if (status == nf90_noerr) then status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%time) else - errmsg = 'SCM data tendency file: '//trim(scheme_sim_file)//' does not contain times variable' + errmsg = 'SCM data tendency file: '//trim(suite_sim_file)//' does not contain times variable' errflg = 1 return endif @@ -403,7 +403,7 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) endif - ! Which process-scheme is "active"? Is process time-split? + ! Which process-suite is "active"? Is process time-split? if (.not. physics_process(iprc)%use_sim) then physics_process(1)%iactive_scheme = iprc physics_process(1)%active_name = physics_process(iprc)%name @@ -416,20 +416,20 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, if (physics_process(1)%iactive_scheme == 0) then errflg = 1 - errmsg = "ERROR: No active scheme set for CCPP scheme simulator" + errmsg = "ERROR: No active suite set for CCPP suite simulator" return endif print*, "-----------------------------------" - print*, "--- Using CCPP scheme simulator ---" + print*, "--- Using CCPP suite simulator ---" print*, "-----------------------------------" do iprc = 1,nprc_sim if (physics_process(iprc)%use_sim) then - print*," simulate_scheme: ", trim(physics_process(iprc)%name) + print*," simulate_suite: ", trim(physics_process(iprc)%name) print*," order: ", physics_process(iprc)%order print*," time_split: ", physics_process(iprc)%time_split else - print*, " active_scheme: ", trim(physics_process(1)%active_name) + print*, " active_suite: ", trim(physics_process(1)%active_name) print*, " order: ", physics_process(physics_process(1)%iactive_scheme)%order print*, " time_split : ", physics_process(1)%active_tsp endif @@ -437,6 +437,6 @@ subroutine load_ccpp_scheme_sim(nlunit, nml_file, physics_process, iactive_T, print*, "-----------------------------------" print*, "-----------------------------------" - end subroutine load_ccpp_scheme_sim + end subroutine load_ccpp_suite_sim -end module GFS_ccpp_scheme_sim_pre +end module GFS_ccpp_suite_sim_pre diff --git a/physics/GFS_ccpp_scheme_sim_pre.meta b/physics/GFS_ccpp_suite_sim_pre.meta similarity index 83% rename from physics/GFS_ccpp_scheme_sim_pre.meta rename to physics/GFS_ccpp_suite_sim_pre.meta index ca6d4f7cc..cc73813fa 100644 --- a/physics/GFS_ccpp_scheme_sim_pre.meta +++ b/physics/GFS_ccpp_suite_sim_pre.meta @@ -1,24 +1,24 @@ [ccpp-table-properties] - name = GFS_ccpp_scheme_sim_pre + name = GFS_ccpp_suite_sim_pre type = scheme - dependencies = machine.F,module_ccpp_scheme_simulator.F90 + dependencies = machine.F,module_ccpp_suite_simulator.F90 ######################################################################## [ccpp-arg-table] - name = GFS_ccpp_scheme_sim_pre_run + name = GFS_ccpp_suite_sim_pre_run type = scheme -[do_ccpp_scheme_sim] - standard_name = flag_for_ccpp_scheme_simulator - long_name = flag for ccpp scheme simulator +[do_ccpp_suite_sim] + standard_name = flag_for_ccpp_suite_simulator + long_name = flag for ccpp suite simulator units = flag dimensions = () type = logical intent = in [physics_process] - standard_name = physics_process_type_for_CCPP_scheme_simulator - long_name = physics process type for CCPP scheme simulator + standard_name = physics_process_type_for_CCPP_suite_simulator + long_name = physics process type for CCPP suite simulator units = mixed - dimensions = (number_of_physics_process_in_CCPP_scheme_simulator) + dimensions = (number_of_physics_process_in_CCPP_suite_simulator) type = base_physics_process intent = in [dtend] @@ -122,37 +122,37 @@ type = integer intent = in [active_phys_tend] - standard_name = tendencies_for_active_process_in_ccpp_scheme_simulator - long_name = tendencies for active physics process in ccpp scheme simulator + standard_name = tendencies_for_active_process_in_ccpp_suite_simulator + long_name = tendencies for active physics process in ccpp suite simulator units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_scheme_simulator) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_suite_simulator) type = real kind = kind_phys intent = out [iactive_T] - standard_name = index_for_active_T_in_CCPP_scheme_simulator - long_name = index into active process tracer array for temperature in CCPP scheme simulator + standard_name = index_for_active_T_in_CCPP_suite_simulator + long_name = index into active process tracer array for temperature in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_u] - standard_name = index_for_active_u_in_CCPP_scheme_simulator - long_name = index into active process tracer array for zonal wind in CCPP scheme simulator + standard_name = index_for_active_u_in_CCPP_suite_simulator + long_name = index into active process tracer array for zonal wind in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_v] - standard_name = index_for_active_v_in_CCPP_scheme_simulator - long_name = index into active process tracer array for meridional wind in CCPP scheme simulator + standard_name = index_for_active_v_in_CCPP_suite_simulator + long_name = index into active process tracer array for meridional wind in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_q] - standard_name = index_for_active_q_in_CCPP_scheme_simulator - long_name = index into active process tracer array for moisture in CCPP scheme simulator + standard_name = index_for_active_q_in_CCPP_suite_simulator + long_name = index into active process tracer array for moisture in CCPP suite simulator units = count dimensions = () type = integer diff --git a/physics/ccpp_scheme_simulator.F90 b/physics/ccpp_suite_simulator.F90 similarity index 91% rename from physics/ccpp_scheme_simulator.F90 rename to physics/ccpp_suite_simulator.F90 index f3a6372ac..c1592263d 100644 --- a/physics/ccpp_scheme_simulator.F90 +++ b/physics/ccpp_suite_simulator.F90 @@ -1,14 +1,14 @@ ! ######################################################################################## ! -! Description: This scheme simulates the evolution of the internal physics state +! Description: This suite simulates the evolution of the internal physics state ! represented by a CCPP Suite Definition File (SDF). ! -! To activate this scheme it must be a) embedded within the SDF and b) activated through +! To activate this suite it must be a) embedded within the SDF and b) activated through ! the physics namelist. ! The derived-data type "base_physics_process" contains the metadata needed to reconstruct ! the temporal evolution of the state. An array of base_physics_process, physics_process, ! is populated by the host during initialization and passed to the physics. Additionally, -! this type holds any data, or type-bound procedures, required by the scheme simulator(s). +! this type holds any data, or type-bound procedures, required by the suite simulator(s). ! ! For this initial demonstration we are using 2-dimensional (height, time) forcing data, ! which is on the same native vertical grid as the SCM. The dataset has a temporal @@ -17,29 +17,29 @@ ! (constant) diurnal cycle. ! ! ######################################################################################## -module ccpp_scheme_simulator +module ccpp_suite_simulator use machine, only: kind_phys - use module_ccpp_scheme_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & + use module_ccpp_suite_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & sim_PBL, sim_GWD, sim_DCNV, sim_SCNV, sim_cldMP implicit none - public ccpp_scheme_simulator_run + public ccpp_suite_simulator_run contains ! ###################################################################################### ! - ! SUBROUTINE ccpp_scheme_simulator_run + ! SUBROUTINE ccpp_suite_simulator_run ! ! ###################################################################################### -!! \section arg_table_ccpp_scheme_simulator_run -!! \htmlinclude ccpp_scheme_simulator_run.html +!! \section arg_table_ccpp_suite_simulator_run +!! \htmlinclude ccpp_suite_simulator_run.html !! - subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, jdat, & + subroutine ccpp_suite_simulator_run(do_ccpp_suite_sim, kdt, nCol, nLay, dtp, jdat, & iactive_T, iactive_u, iactive_v, iactive_q, proc_start, proc_end, physics_process,& in_pre_active, in_post_active, tgrs, ugrs, vgrs, qgrs, active_phys_tend, gt0, gu0,& gv0, gq0, errmsg, errflg) ! Inputs - logical, intent(in) :: do_ccpp_scheme_sim + logical, intent(in) :: do_ccpp_suite_sim integer, intent(in) :: kdt, nCol, nLay, jdat(8), iactive_T, iactive_u, & iactive_v, iactive_q real(kind_phys), intent(in) :: dtp, tgrs(:,:), ugrs(:,:), vgrs(:,:), qgrs(:,:,:), & @@ -60,7 +60,7 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j errmsg = '' errflg = 0 - if (.not. do_ccpp_scheme_sim) return + if (.not. do_ccpp_suite_sim) return ! Current forecast time (Data-format specific) year = jdat(1) @@ -207,6 +207,6 @@ subroutine ccpp_scheme_simulator_run(do_ccpp_scheme_sim, kdt, nCol, nLay, dtp, j in_post_active = .false. endif - end subroutine ccpp_scheme_simulator_run + end subroutine ccpp_suite_simulator_run -end module ccpp_scheme_simulator +end module ccpp_suite_simulator diff --git a/physics/ccpp_scheme_simulator.meta b/physics/ccpp_suite_simulator.meta similarity index 76% rename from physics/ccpp_scheme_simulator.meta rename to physics/ccpp_suite_simulator.meta index c60cd9a38..f2737a263 100644 --- a/physics/ccpp_scheme_simulator.meta +++ b/physics/ccpp_suite_simulator.meta @@ -1,14 +1,14 @@ [ccpp-table-properties] - name = ccpp_scheme_simulator + name = ccpp_suite_simulator type = scheme - dependencies = machine.F,module_ccpp_scheme_simulator.F90 + dependencies = machine.F,module_ccpp_suite_simulator.F90 [ccpp-arg-table] - name = ccpp_scheme_simulator_run + name = ccpp_suite_simulator_run type = scheme -[do_ccpp_scheme_sim] - standard_name = flag_for_ccpp_scheme_simulator - long_name = flag for ccpp scheme simulator +[do_ccpp_suite_sim] + standard_name = flag_for_ccpp_suite_simulator + long_name = flag for ccpp suite simulator units = flag dimensions = () type = logical @@ -50,29 +50,29 @@ type = integer intent = in [proc_start] - standard_name = index_for_first_physics_process_in_CCPP_scheme_simulator - long_name = index for first physics process in CCPP scheme simulator + standard_name = index_for_first_physics_process_in_CCPP_suite_simulator + long_name = index for first physics process in CCPP suite simulator units = count dimensions = () type = integer intent = inout [proc_end] - standard_name = index_for_last_physics_process_in_CCPP_scheme_simulator - long_name = index for last physics process in CCPP scheme simulator + standard_name = index_for_last_physics_process_in_CCPP_suite_simulator + long_name = index for last physics process in CCPP suite simulator units = count dimensions = () type = integer intent = inout [in_pre_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_scheme - long_name = flag to indicate location in physics process loop before active scheme + standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_suite + long_name = flag to indicate location in physics process loop before active suite units = flag dimensions = () type = logical intent = inout [in_post_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_scheme - long_name = flag to indicate location in physics process loop after active scheme + standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_suite + long_name = flag to indicate location in physics process loop after active suite units = flag dimensions = () type = logical @@ -110,37 +110,37 @@ kind = kind_phys intent = in [active_phys_tend] - standard_name = tendencies_for_active_process_in_ccpp_scheme_simulator - long_name = tendencies for active physics process in ccpp scheme simulator + standard_name = tendencies_for_active_process_in_ccpp_suite_simulator + long_name = tendencies for active physics process in ccpp suite simulator units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_scheme_simulator) + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_suite_simulator) type = real kind = kind_phys intent = in [iactive_T] - standard_name = index_for_active_T_in_CCPP_scheme_simulator - long_name = index into active process tracer array for temperature in CCPP scheme simulator + standard_name = index_for_active_T_in_CCPP_suite_simulator + long_name = index into active process tracer array for temperature in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_u] - standard_name = index_for_active_u_in_CCPP_scheme_simulator - long_name = index into active process tracer array for zonal wind in CCPP scheme simulator + standard_name = index_for_active_u_in_CCPP_suite_simulator + long_name = index into active process tracer array for zonal wind in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_v] - standard_name = index_for_active_v_in_CCPP_scheme_simulator - long_name = index into active process tracer array for meridional wind in CCPP scheme simulator + standard_name = index_for_active_v_in_CCPP_suite_simulator + long_name = index into active process tracer array for meridional wind in CCPP suite simulator units = count dimensions = () type = integer intent = in [iactive_q] - standard_name = index_for_active_q_in_CCPP_scheme_simulator - long_name = index into active process tracer array for moisture in CCPP scheme simulator + standard_name = index_for_active_q_in_CCPP_suite_simulator + long_name = index into active process tracer array for moisture in CCPP suite simulator units = count dimensions = () type = integer @@ -178,10 +178,10 @@ kind = kind_phys intent = inout [physics_process] - standard_name = physics_process_type_for_CCPP_scheme_simulator - long_name = physics process type for CCPP scheme simulator + standard_name = physics_process_type_for_CCPP_suite_simulator + long_name = physics process type for CCPP suite simulator units = mixed - dimensions = (number_of_physics_process_in_CCPP_scheme_simulator) + dimensions = (number_of_physics_process_in_CCPP_suite_simulator) type = base_physics_process intent = inout [errmsg] diff --git a/physics/module_ccpp_scheme_simulator.F90 b/physics/module_ccpp_suite_simulator.F90 similarity index 98% rename from physics/module_ccpp_scheme_simulator.F90 rename to physics/module_ccpp_suite_simulator.F90 index a122563d9..c759c583a 100644 --- a/physics/module_ccpp_scheme_simulator.F90 +++ b/physics/module_ccpp_suite_simulator.F90 @@ -1,12 +1,12 @@ ! ######################################################################################## ! ! This module contains the type, base_physics_process, and supporting subroutines needed -! by the ccpp scheme simulator. +! by the ccpp suite simulator. ! ! ######################################################################################## -module module_ccpp_scheme_simulator -!> \section arg_table_module_ccpp_scheme_simulator Argument table -!! \htmlinclude module_ccpp_scheme_simulator.html +module module_ccpp_suite_simulator +!> \section arg_table_module_ccpp_suite_simulator Argument table +!! \htmlinclude module_ccpp_suite_simulator.html !! use machine, only : kind_phys implicit none @@ -307,4 +307,4 @@ subroutine sim_cldMP( year, month, day, hour, min, sec, process) endif end subroutine sim_cldMP -end module module_ccpp_scheme_simulator +end module module_ccpp_suite_simulator diff --git a/physics/module_ccpp_scheme_simulator.meta b/physics/module_ccpp_suite_simulator.meta similarity index 86% rename from physics/module_ccpp_scheme_simulator.meta rename to physics/module_ccpp_suite_simulator.meta index 8eefb228c..cd8e3db1b 100644 --- a/physics/module_ccpp_scheme_simulator.meta +++ b/physics/module_ccpp_suite_simulator.meta @@ -9,12 +9,12 @@ ######################################################################## [ccpp-table-properties] - name = module_ccpp_scheme_simulator + name = module_ccpp_suite_simulator type = module dependencies = machine.F [ccpp-arg-table] - name = module_ccpp_scheme_simulator + name = module_ccpp_suite_simulator type = module [base_physics_process] standard_name = base_physics_process From 2d6d44c8d56aa707d4e11901f1965df322c2322a Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 19 Jul 2023 16:12:43 -0600 Subject: [PATCH 28/64] Omission from previous commit --- physics/ccpp_suite_simulator.meta | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/ccpp_suite_simulator.meta b/physics/ccpp_suite_simulator.meta index f2737a263..bfa664922 100644 --- a/physics/ccpp_suite_simulator.meta +++ b/physics/ccpp_suite_simulator.meta @@ -64,15 +64,15 @@ type = integer intent = inout [in_pre_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_suite - long_name = flag to indicate location in physics process loop before active suite + standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_scheme + long_name = flag to indicate location in physics process loop before active scheme units = flag dimensions = () type = logical intent = inout [in_post_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_suite - long_name = flag to indicate location in physics process loop after active suite + standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_scheme + long_name = flag to indicate location in physics process loop after active scheme units = flag dimensions = () type = logical From 5ab1a5bb7385214ec8febaa0d2bef2f6a1377481 Mon Sep 17 00:00:00 2001 From: dustinswales Date: Wed, 19 Jul 2023 16:48:11 -0600 Subject: [PATCH 29/64] Add ability to use constant forcing data when one-dimensional data is provided. --- physics/module_ccpp_suite_simulator.F90 | 28 ++++++++++++++++++++----- 1 file changed, 23 insertions(+), 5 deletions(-) diff --git a/physics/module_ccpp_suite_simulator.F90 b/physics/module_ccpp_suite_simulator.F90 index c759c583a..c4f9fc4e4 100644 --- a/physics/module_ccpp_suite_simulator.F90 +++ b/physics/module_ccpp_suite_simulator.F90 @@ -94,21 +94,39 @@ function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err character(len=*), intent(in) :: var_name integer, intent(in) :: year, month, day, hour, min, sec character(len=128) :: err_message - integer :: ti(1), tf(1) + integer :: ti(1), tf(1), ntime real(kind_phys) :: w1, w2 ! Interpolation weights call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) + ntime = size(this%tend2d%T(1,:)) + select case(var_name) case("T") - this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) + if (tf(1) .le. ntime) then + this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) + else + this%tend1d%T = this%tend2d%T(:,1) + endif case("u") - this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) + if (tf(1) .le. ntime) then + this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) + else + this%tend1d%u = this%tend2d%u(:,1) + endif case("v") - this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) + if (tf(1) .le. ntime) then + this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) + else + this%tend1d%v = this%tend2d%v(:,1) + endif case("q") - this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) + if (tf(1) .le. ntime) then + this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) + else + this%tend1d%q = this%tend2d%q(:,1) + endif end select end function linterp_1D From 9891fff7bd9eb8660a60ff203112298bf1349406 Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Mon, 31 Jul 2023 10:50:36 -0600 Subject: [PATCH 30/64] switch from in to inout for output variables --- physics/sfc_land.f | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/sfc_land.f b/physics/sfc_land.f index aec47ff77..d4e88c25a 100644 --- a/physics/sfc_land.f +++ b/physics/sfc_land.f @@ -112,7 +112,7 @@ subroutine sfc_land_run & & cmm_lnd, chh_lnd, zvfun_lnd ! --- outputs: - real (kind=kind_phys), dimension(:), intent(out) :: & + real (kind=kind_phys), dimension(:), intent(inout) :: & & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux, & & runoff, drain, cmm, chh, zvfun ! From 70038f6f5f70572f09489732e3563f1d11066a1f Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Mon, 31 Jul 2023 11:50:02 -0600 Subject: [PATCH 31/64] update meta file for sfc_land too --- physics/sfc_land.meta | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/physics/sfc_land.meta b/physics/sfc_land.meta index 979cca377..493d2a70b 100644 --- a/physics/sfc_land.meta +++ b/physics/sfc_land.meta @@ -153,7 +153,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [qsurf] standard_name = surface_specific_humidity_over_land long_name = surface air saturation specific humidity over land @@ -161,7 +161,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [evap] standard_name = kinematic_surface_upward_latent_heat_flux_over_land long_name = kinematic surface upward latent heat flux over land @@ -169,7 +169,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [hflx] standard_name = kinematic_surface_upward_sensible_heat_flux_over_land long_name = kinematic surface upward sensible heat flux over land @@ -177,7 +177,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [ep] standard_name = surface_upward_potential_latent_heat_flux_over_land long_name = surface upward potential latent heat flux over land @@ -185,7 +185,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [t2mmp] standard_name = temperature_at_2m_from_noahmp long_name = 2 meter temperature from noahmp @@ -193,7 +193,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [q2mp] standard_name = specific_humidity_at_2m_from_noahmp long_name = 2 meter specific humidity from noahmp @@ -201,7 +201,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [gflux] standard_name = upward_heat_flux_in_soil_over_land long_name = soil heat flux over land @@ -209,7 +209,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [runoff] standard_name = surface_runoff_flux long_name = surface runoff flux @@ -217,7 +217,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [drain] standard_name = subsurface_runoff_flux long_name = subsurface runoff flux @@ -225,7 +225,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [cmm] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_land long_name = momentum exchange coefficient over land @@ -233,7 +233,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [chh] standard_name = surface_drag_mass_flux_for_heat_and_moisture_in_air_over_land long_name = thermal exchange coefficient over land @@ -241,7 +241,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [zvfun] standard_name = function_of_surface_roughness_length_and_green_vegetation_fraction long_name = function of surface roughness length and green vegetation fraction @@ -249,7 +249,7 @@ dimensions = (horizontal_loop_extent) type = real kind = kind_phys - intent = out + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP From 6ec72e918d2f2d04f78a9afaf5b58968370a44a4 Mon Sep 17 00:00:00 2001 From: uturuncoglu Date: Mon, 31 Jul 2023 16:21:27 -0600 Subject: [PATCH 32/64] update sfc_land --- physics/sfc_land.F90 | 108 ++++++++++++++++++++++++++++++ physics/sfc_land.f | 154 ------------------------------------------- 2 files changed, 108 insertions(+), 154 deletions(-) create mode 100644 physics/sfc_land.F90 delete mode 100644 physics/sfc_land.f diff --git a/physics/sfc_land.F90 b/physics/sfc_land.F90 new file mode 100644 index 000000000..2b0696ed8 --- /dev/null +++ b/physics/sfc_land.F90 @@ -0,0 +1,108 @@ +!> \file sfc_land.F90 +!! This file contains the code for coupling to land component + +!> This module contains the CCPP-compliant GFS land post +!! interstitial codes, which returns updated surface +!! properties such as latent heat and sensible heat +!! provided by the component version of land model + +!> This module contains the CCPP-compliant GFS land scheme. + module sfc_land + + use machine, only : kind_phys + + contains + +!> \defgroup sfc_land for coupling to land +!! @{ +!! \section diagram Calling Hierarchy Diagram +!! \section intraphysics Intraphysics Communication +!! +!> \brief Brief description of the subroutine +!! +!! \section arg_table_sfc_land_run Arguments +!! \htmlinclude sfc_land_run.html +!! + +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ + subroutine sfc_land_run(im, cpllnd, cpllnd2atm, flag_iter, dry, & + sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & + ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & + runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, zvfun_lnd, & + sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & + gflux, runoff, drain, cmm, chh, zvfun, & + errmsg, errflg) + + implicit none + + ! Inputs + integer , intent(in) :: im + logical , intent(in) :: cpllnd + logical , intent(in) :: cpllnd2atm + logical , intent(in) :: flag_iter(:) + logical , intent(in) :: dry(:) + real(kind=kind_phys), intent(in) :: sncovr1_lnd(:) + real(kind=kind_phys), intent(in) :: qsurf_lnd(:) + real(kind=kind_phys), intent(in) :: evap_lnd(:) + real(kind=kind_phys), intent(in) :: hflx_lnd(:) + real(kind=kind_phys), intent(in) :: ep_lnd(:) + real(kind=kind_phys), intent(in) :: t2mmp_lnd(:) + real(kind=kind_phys), intent(in) :: q2mp_lnd(:) + real(kind=kind_phys), intent(in) :: gflux_lnd(:) + real(kind=kind_phys), intent(in) :: runoff_lnd(:) + real(kind=kind_phys), intent(in) :: drain_lnd(:) + real(kind=kind_phys), intent(in) :: cmm_lnd(:) + real(kind=kind_phys), intent(in) :: chh_lnd(:) + real(kind=kind_phys), intent(in) :: zvfun_lnd(:) + ! Inputs/Outputs + real(kind=kind_phys), intent(inout) :: sncovr1(:) + real(kind=kind_phys), intent(inout) :: qsurf(:) + real(kind=kind_phys), intent(inout) :: evap(:) + real(kind=kind_phys), intent(inout) :: hflx(:) + real(kind=kind_phys), intent(inout) :: ep(:) + real(kind=kind_phys), intent(inout) :: t2mmp(:) + real(kind=kind_phys), intent(inout) :: q2mp(:) + real(kind=kind_phys), intent(inout) :: gflux(:) + real(kind=kind_phys), intent(inout) :: runoff(:) + real(kind=kind_phys), intent(inout) :: drain(:) + real(kind=kind_phys), intent(inout) :: cmm(:) + real(kind=kind_phys), intent(inout) :: chh(:) + real(kind=kind_phys), intent(inout) :: zvfun(:) + ! Outputs + character(len=*) , intent(out) :: errmsg + integer , intent(out) :: errflg + + ! Locals + integer :: i + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check coupling from component land to atmosphere + if (.not. cpllnd2atm) return + + ! Fill variables + do i = 1, im + sncovr1(i) = sncovr1_lnd(i) + qsurf(i) = qsurf_lnd(i) + hflx(i) = hflx_lnd(i) + evap(i) = evap_lnd(i) + ep(i) = ep_lnd(i) + t2mmp(i) = t2mmp_lnd(i) + q2mp(i) = q2mp_lnd(i) + gflux(i) = gflux_lnd(i) + drain(i) = drain_lnd(i) + runoff(i) = runoff_lnd(i) + cmm(i) = cmm_lnd(i) + chh(i) = chh_lnd(i) + zvfun(i) = zvfun_lnd(i) + enddo + + end subroutine sfc_land_run + +!> @} + end module sfc_land diff --git a/physics/sfc_land.f b/physics/sfc_land.f deleted file mode 100644 index d4e88c25a..000000000 --- a/physics/sfc_land.f +++ /dev/null @@ -1,154 +0,0 @@ -!> \file sfc_land.f -!! This file contains the code for coupling to land component - -!> This module contains the CCPP-compliant GFS land post -!! interstitial codes, which returns updated surface -!! properties such as latent heat and sensible heat -!! provided by the component version of land model - -!> This module contains the CCPP-compliant GFS land scheme. - module sfc_land - - contains - -!> \defgroup sfc_land for coupling to land -!! @{ -!! \section diagram Calling Hierarchy Diagram -!! \section intraphysics Intraphysics Communication -!! -!> \brief Brief description of the subroutine -!! -!! \section arg_table_sfc_land_run Arguments -!! \htmlinclude sfc_land_run.html -!! - -!! -!! \section general General Algorithm -!! \section detailed Detailed Algorithm -!! @{ - -! -!----------------------------------- - subroutine sfc_land_run & -! --- inputs: - & ( im, cpllnd, cpllnd2atm, flag_iter, dry, & - & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, & - & ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, & - & runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, zvfun_lnd, & -! --- outputs: - & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, & - & gflux, runoff, drain, cmm, chh, zvfun, & - & errmsg, errflg - & ) - -! ===================================================================== ! -! description: ! -! Dec 2022 -- Ufuk Turuncoglu created for coupling to land ! -! ! -! usage: ! -! ! -! call sfc_land ! -! inputs: ! -! ( im, cpllnd, cpllnd2atm, flag_iter, dry, ! -! sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ! -! ep_lnd, t2mmp_lnd, q2mp_lnd, gflux_lnd, ! -! runoff_lnd, drain_lnd, cmm_lnd, chh_lnd, ! -! zvfun_lnd, ! -! outputs: ! -! sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, ! -! gflux, runoff, drain, cmm, chh, zvfun, ! -! errmsg, errflg) ! -! ! -! ==================== defination of variables ==================== ! -! ! -! inputs: -! im - integer, horiz dimension -! cpllnd - logical, flag for land coupling -! cpllnd2atm - logical, flag for land coupling (lnd->atm) -! flag_iter - logical, flag for iteration -! dry - logical, eq T if a point with any land -! sncovr1_lnd - real , surface snow area fraction -! qsurf_lnd - real , specific humidity at sfc -! evap_lnd - real , evaporation from latent heat -! hflx_lnd - real , sensible heat -! ep_lnd - real , surface upward potential latent heat flux -! t2mmp_lnd - real , 2m temperature -! q2mp_lnd - real , 2m specific humidity -! gflux_lnd - real , soil heat flux over land -! runoff_lnd - real , surface runoff -! drain_lnd - real , subsurface runoff -! cmm_lnd - real , surface drag wind speed for momentum -! chh_lnd - real , surface drag mass flux for heat and moisture -! zvfun_lnd - real , function of surface roughness length and green vegetation fraction -! outputs: -! sncovr1 - real , snow cover over land -! qsurf - real , specific humidity at sfc -! evap - real , evaporation from latent heat -! hflx - real , sensible heat -! ep - real , potential evaporation -! t2mmp - real , temperature at 2m -! q2mp - real , specific humidity at 2m -! gflux - real , soil heat flux over land -! runoff - real , surface runoff -! drain - real , subsurface runoff -! cmm - real , surface drag wind speed for momentum -! chh - real , surface drag mass flux for heat and moisture -! zvfun - real , function of surface roughness length and green vegetation fraction -! ==================== end of description ===================== ! -! -! - use machine , only : kind_phys - implicit none - -! --- inputs: - integer, intent(in) :: im - logical, intent(in) :: cpllnd, cpllnd2atm - logical, dimension(:), intent(in) :: flag_iter - logical, dimension(:), intent(in) :: dry - - real (kind=kind_phys), dimension(:), intent(in) :: & - & sncovr1_lnd, qsurf_lnd, evap_lnd, hflx_lnd, ep_lnd, & - & t2mmp_lnd, q2mp_lnd, gflux_lnd, runoff_lnd, drain_lnd, & - & cmm_lnd, chh_lnd, zvfun_lnd - -! --- outputs: - real (kind=kind_phys), dimension(:), intent(inout) :: & - & sncovr1, qsurf, evap, hflx, ep, t2mmp, q2mp, gflux, & - & runoff, drain, cmm, chh, zvfun -! - character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg - -! --- locals: - - integer :: i - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 -! - if (.not. cpllnd2atm) return -! - do i = 1, im - sncovr1(i) = sncovr1_lnd(i) - qsurf(i) = qsurf_lnd(i) - hflx(i) = hflx_lnd(i) - evap(i) = evap_lnd(i) - ep(i) = ep_lnd(i) - t2mmp(i) = t2mmp_lnd(i) - q2mp(i) = q2mp_lnd(i) - gflux(i) = gflux_lnd(i) - drain(i) = drain_lnd(i) - runoff(i) = runoff_lnd(i) - cmm(i) = cmm_lnd(i) - chh(i) = chh_lnd(i) - zvfun(i) = zvfun_lnd(i) - enddo - - return -!----------------------------------- - end subroutine sfc_land_run -!----------------------------------- - -!> @} - end module sfc_land From 4e45989d1f6f78bb05aa789289d4cebebe9217b7 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 16 Oct 2023 09:46:45 -0400 Subject: [PATCH 33/64] Code update for HR4_roughness --- physics/sfc_diff.f | 43 +++++++++++++++++++++++++++++-------------- 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 6e834537a..561a087c4 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -348,12 +348,26 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tvs = half * (tsurf_wat(i)+tskin_wat(i))/prsik1(i) & * virtfac endif - - z0 = 0.01_kp * z0rl_wat(i) - z0max = max(zmin, min(z0,z1(i))) -! ustar_wat(i) = sqrt(grav * z0 / charnock) +! wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) +! + if (sfc_z0_type == -1) then ! using wave model derived momentum roughness + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + 0.01_kp * z0rl_wav(i) + if (redrag) then + z0max = max(min(z0, z0s_max),1.0e-7_kp) + else + z0max = max(min(z0,0.1_kp), 1.0e-7_kp) + endif + z0rl_wat(i) = 100.0_kp * z0max ! cm + else + z0 = 0.01_kp * z0rl_wat(i) + z0max = max(zmin, min(z0,z1(i))) + endif +! +! ustar_wat(i) = sqrt(grav * z0 / charnock) +! !** test xubin's new z0 ! ztmax = z0max @@ -423,17 +437,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_kp endif - elseif (z0rl_wav(i) <= 1.0e-7_kp .or. & - & z0rl_wav(i) > 1.0_kp) then -! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) - tem1 = 0.11 * vis / ustar_wat(i) - z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) +! elseif (z0rl_wav(i) <= 1.0e-7_kp .or. & +! & z0rl_wav(i) > 1.0_kp) then +!! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) +! tem1 = 0.11 * vis / ustar_wat(i) +! z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + +! if (redrag) then +! z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) +! else +! z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) +! endif - if (redrag) then - z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) - else - z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) - endif endif endif ! end of if(open ocean) From 3debf89fdc94111624f0b99da71e605418824183 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 16 Oct 2023 10:45:21 -0400 Subject: [PATCH 34/64] Code update for HR4_roughness --- physics/sfc_diff.f | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 561a087c4..d56308b79 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -437,18 +437,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_kp endif -! elseif (z0rl_wav(i) <= 1.0e-7_kp .or. & -! & z0rl_wav(i) > 1.0_kp) then -!! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) -! tem1 = 0.11 * vis / ustar_wat(i) -! z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) - -! if (redrag) then -! z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) -! else -! z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) -! endif - endif endif ! end of if(open ocean) From c2b130113acf235e7c5e65bfd5f97ca2e8e3a3d7 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Mon, 16 Oct 2023 10:55:07 -0400 Subject: [PATCH 35/64] Code update for HR4_roughness --- physics/sfc_diff.f | 2 -- 1 file changed, 2 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index d56308b79..b28daef3b 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -366,8 +366,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(zmin, min(z0,z1(i))) endif ! -! ustar_wat(i) = sqrt(grav * z0 / charnock) -! !** test xubin's new z0 ! ztmax = z0max From 9dc3d4063619b999316e2e269a3eb37d3c169173 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Mon, 20 Nov 2023 15:57:15 +0000 Subject: [PATCH 36/64] Inlcude surface ocean currents for the calculation of the air-sea fluxes. --- physics/satmedmfvdifq.F | 9 ++++++--- physics/satmedmfvdifq.meta | 16 ++++++++++++++++ physics/sfc_diff.f | 10 ++++++++-- physics/sfc_diff.meta | 23 +++++++++++++++++++++++ physics/sfc_nst.f | 13 ++++++++----- physics/sfc_nst.meta | 16 ++++++++++++++++ physics/sfc_ocean.F | 21 +++++++++++++-------- physics/sfc_ocean.meta | 16 ++++++++++++++++ z | 16 ++++++++++++++++ 9 files changed, 122 insertions(+), 18 deletions(-) create mode 100644 z diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 73fc4aff8..4ccf47060 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -75,7 +75,7 @@ end subroutine satmedmfvdifq_init !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu, & + & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,swh,hlw,xmu, & & garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & @@ -110,6 +110,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & + & ssu(:), ssv(:), & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & @@ -2376,8 +2377,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo enddo do i = 1,im - dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) - dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) +! dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) +! dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1(i) enddo ! if(ldiag3d .and. .not. gen_tend) then diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index b6680dccb..b21e5d4f2 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -217,6 +217,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [t1] standard_name = air_temperature long_name = layer mean air temperature diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 6e834537a..e4abf42d9 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,6 +61,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) + & u1,v1,ssu,ssv & !intent(in) & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -95,6 +96,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation real(kind=kind_phys), dimension(:), intent(in) :: u10m,v10m + real(kind=kind_phys), dimension(:), intent(in) :: u1,v1,ssu,ssv real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav real(kind=kind_phys), dimension(:), intent(in) :: & & ps,t1,q1,z1,garea,prsl1,prslki,prsik1,prslk1, & @@ -128,6 +130,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, & czilc, tem1, tem2, virtfac + real(kind=kind_phys), dimension(im) :: windrel ! real(kind=kind_phys) :: tvs, z0, z0max, ztmax, gdx @@ -167,6 +170,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + do i=1,im + windrel(i) = sqrt((u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2) + enddo do i=1,im if(flag_iter(i)) then @@ -274,7 +280,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), @@ -328,7 +334,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index eb30b8c50..95e2bce81 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -102,6 +102,13 @@ type = real kind = kind_phys intent = in +[windrel] + standard_name = relative_wind_speed_at_lowest_model_layer + long_name = relative wind speed at lowest model level + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys [prsl1] standard_name = air_pressure_at_surface_adjacent_layer long_name = Model layer 1 mean pressure @@ -210,6 +217,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [sfc_z0_type] standard_name = flag_for_surface_roughness_option_over_water long_name = surface roughness options over water diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 2ca70666d..4855d7224 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -16,7 +16,7 @@ module sfc_nst !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm subroutine sfc_nst_run & & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: - & pi, tgice, sbc, ps, u1, v1, t1, q1, tref, cm, ch, & + & pi, tgice, sbc, ps, u1, v1, ssu, ssv, t1, q1, tref, cm, ch,& & lseaspray, fm, fm10, & & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & & sinlat, stress, & @@ -36,7 +36,7 @@ subroutine sfc_nst_run & ! ! ! call sfc_nst ! ! inputs: ! -! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! +! ( im, ps, u1, v1, ssu, ssv,t1, q1, tref, cm, ch, ! ! lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! @@ -222,6 +222,7 @@ subroutine sfc_nst_run & & rho_a, theta1, tv1, wndmag real(kind=kind_phys) elocp,tem,cpinv,hvapi + real(kind=kind_phys) windref ! ! nstm related prognostic fields ! @@ -309,7 +310,9 @@ subroutine sfc_nst_run & ! qss is saturation specific humidity at the water surface !! do i = 1, im +! windref = wind(i) if ( flag(i) ) then + windref = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) @@ -334,9 +337,9 @@ subroutine sfc_nst_run & ! --- ... rcp = rho cp ch v - rch(i) = rho_a(i) * cp * ch(i) * wind(i) - cmm(i) = cm (i) * wind(i) - chh(i) = rho_a(i) * ch(i) * wind(i) + rch(i) = rho_a(i) * cp * ch(i) * windref + cmm(i) = cm (i) * windref + chh(i) = rho_a(i) * ch(i) * windref !> - Calculate latent and sensible heat flux over open water with tskin. ! at previous time step diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index dc35ec959..10330fbb3 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -134,6 +134,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = surface layer mean temperature diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 78d58d8f0..2423bd8d9 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -24,7 +24,7 @@ subroutine sfc_ocean_run & !................................... ! --- inputs: & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & - & tskin, cm, ch, lseaspray, fm, fm10, & + & tskin, cm, ch, lseaspray, fm, fm10, ssu, ssv, & & prsl1, prslki, wet, use_lake_model, wind, &, ! --- inputs & flag_iter, use_med_flux, dqsfc_med, dtsfc_med, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs @@ -66,6 +66,7 @@ subroutine sfc_ocean_run & ! im - integer, horizontal dimension 1 ! ! ps - real, surface pressure im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! +! ssu,ssv - real, u/v component of surface ocean current (m/s) im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! @@ -109,7 +110,8 @@ subroutine sfc_ocean_run & & eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind + & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind, ssu, & + & ssv ! For sea spray effect logical, intent(in) :: lseaspray @@ -133,7 +135,7 @@ subroutine sfc_ocean_run & ! --- locals: real (kind=kind_phys) :: qss, rch, tem, - & elocp, cpinv, hvapi + & elocp, cpinv, hvapi, windref real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i @@ -157,6 +159,7 @@ subroutine sfc_ocean_run & ! -- ... initialize CCPP error handling variables errmsg = '' errflg = 0 + print *, 'ssu ssv',ssu(1),ssv(1) cpinv = one/cp hvapi = one/hvap @@ -169,13 +172,15 @@ subroutine sfc_ocean_run & ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface +! windref = wind(i) if ( flag(i) ) then + windref = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) if (use_med_flux) then q0(i) = max( q1(i), qmin ) rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) - tem = ch(i) * wind(i) - cmm(i) = cm(i) * wind(i) + tem = ch(i) * windref + cmm(i) = cm(i) * windref chh(i) = rho(i) * tem hflx(i) = dtsfc_med(i) @@ -192,9 +197,9 @@ subroutine sfc_ocean_run & ! --- ... rcp = rho cp ch v - rch = rho(i) * cp * ch(i) * wind(i) - tem = ch(i) * wind(i) - cmm(i) = cm(i) * wind(i) + rch = rho(i) * cp * ch(i) * windref + tem = ch(i) * windref + cmm(i) = cm(i) * windref chh(i) = rho(i) * tem !> - Calcualte sensible and latent heat flux over open water diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 15812e723..7d2e55e27 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -86,6 +86,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = surface layer mean temperature diff --git a/z b/z new file mode 100644 index 000000000..c1bc228c7 --- /dev/null +++ b/z @@ -0,0 +1,16 @@ +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in From 32584c2807800047cbc34d8db423569292eca492 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Sat, 25 Nov 2023 15:29:18 +0000 Subject: [PATCH 37/64] Use the ocean current field for the air-sea flux calculation. --- physics/satmedmfvdif.F | 19 ++++++++++++++++++- physics/satmedmfvdif.meta | 16 ++++++++++++++++ physics/satmedmfvdifq.F | 19 +++++++++++++++++++ physics/sfc_diag.f | 21 +++++++++++++++++++-- physics/sfc_diag.meta | 16 ++++++++++++++++ physics/sfc_diff.f | 26 ++++++++++++++++++++++---- physics/sfc_nst.f | 32 ++++++++++++++++++++++++-------- physics/sfc_ocean.F | 31 ++++++++++++++++++++++--------- z | 16 ---------------- 9 files changed, 156 insertions(+), 40 deletions(-) delete mode 100644 z diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index 79f7bbea1..a0441e8f4 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -63,7 +63,7 @@ end subroutine satmedmfvdif_init !> @{ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea, & + & dv,du,tdt,rtg,u1,v1,ssu,ssv,t1,q1,swh,hlw,xmu,garea, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -95,6 +95,7 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & + & ssu(:), ssv(:), & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & @@ -217,6 +218,9 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & ! real(kind=kind_phys) h1 integer :: idtend + integer ii + real(kind=kind_phys) :: ssumax, ssvmax + logical :: check_ssu_ssv !! parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) @@ -250,6 +254,19 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 +! + check_ssu_ssv=.true. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + !windrel(ii) = sqrt((u1(ii)-ssu(ii))**2+(v1(ii)-ssv(ii))**2) + enddo + print*, 'in satmedmfvdif.F ssumax,ssvmax =',ssumax,ssvmax + endif + !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. !> -# Compute preliminary variables from input arguments dt2 = delt diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 3609ed50f..522ce543b 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -211,6 +211,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [t1] standard_name = air_temperature long_name = layer mean air temperature diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 4ccf47060..62bf6473f 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -280,6 +280,25 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) +!BL + integer ii + real(kind=kind_phys) :: ssumax, ssvmax + logical :: check_ssu_ssv + + write(*,*)'in_satmedmfvdifq,u1 v1',u1(1,1),v1(1,1) + check_ssu_ssv=.true. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + enddo + print*, 'in satmedmfvdifq.F ssumax,ssvmax =',ssumax,ssvmax + endif + !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. +!BL + if (tc_pbl == 0) then ck0 = 0.4 ch0 = 0.4 diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 768814e8c..b9006d6a9 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -17,6 +17,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & & con_karman, & & shflx,cdq,wind, & + & ssu,ssv, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & use_lake_model,iopt_lake,iopt_lake_clm, & @@ -38,6 +39,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & & zf, ps, u1, v1, t1, q1, ust, tskin, & + & ssu, ssv, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & @@ -67,10 +69,25 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! real(kind=kind_phys) sig2k, fhi, qss ! ! real, parameter :: g=grav + integer ii + real(kind=kind_phys) :: ssumax, ssvmax + logical :: check_ssu_ssv ! ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + + check_ssu_ssv=.true. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + enddo + print*, 'in sfc_diag ssumax,ssvmax =',ssumax,ssvmax + endif + !if(abs(ssumax-0.02).lt.0.01) check_ssu_ssv=.false. !-- testptlat = 35.3_kind_phys @@ -89,8 +106,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) - u10m(i) = f10m(i) * u1(i) - v10m(i) = f10m(i) * v1(i) + u10m(i) = ssu(i) + f10m(i) * (u1(i)-ssu(i)) + v10m(i) = ssv(i) + f10m(i) * (v1(i)-ssv(i)) have_2m = use_lake_model(i)>0 .and. use_lake2m .and. & & iopt_lake==iopt_lake_clm if(have_2m) then diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index a16290b58..9a8a5517e 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -123,6 +123,22 @@ type = real kind = kind_phys intent = in +[ssu] + standard_name = ocn_current_zonal + long_name = ocn_current_zonal + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[ssv] + standard_name = ocn_current_merid + long_name = ocn_current_merid + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index e4abf42d9..0ac51fda0 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,7 +61,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) - & u1,v1,ssu,ssv & !intent(in) + & u1,v1,ssu,ssv, & & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -127,10 +127,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! locals ! integer i + integer ii + real(kind=kind_phys) :: ssumax, ssvmax + real(kind=kind_phys), dimension(im) :: windrel + logical :: check_ssu_ssv ! real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, & czilc, tem1, tem2, virtfac - real(kind=kind_phys), dimension(im) :: windrel ! real(kind=kind_phys) :: tvs, z0, z0max, ztmax, gdx @@ -168,11 +171,26 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm ! + ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + + check_ssu_ssv=.true. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + enddo + print*, 'in sfc_diff ssumax,ssvmax =',ssumax,ssvmax + print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + endif + !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. do i=1,im - windrel(i) = sqrt((u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2) + windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) enddo + do i=1,im if(flag_iter(i)) then @@ -389,7 +407,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), & z0max, ztmax_wat(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 4855d7224..8aad8fc8f 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -36,7 +36,7 @@ subroutine sfc_nst_run & ! ! ! call sfc_nst ! ! inputs: ! -! ( im, ps, u1, v1, ssu, ssv,t1, q1, tref, cm, ch, ! +! ( im, ps, u1, v1, ssu,ssv, t1, q1, tref, cm, ch, ! ! lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! @@ -75,6 +75,7 @@ subroutine sfc_nst_run & ! im - integer, horiz dimension 1 ! ! ps - real, surface pressure (pa) im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! +! ssu, ssv - real, u/v component of surface current (m/s) im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tref - real, reference/foundation temperature ( k ) im ! @@ -185,7 +186,7 @@ subroutine sfc_nst_run & real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tref, cm, ch, fm, fm10, & + & ssu, ssv, t1, q1, tref, cm, ch, fm, fm10, & & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind real (kind=kind_phys), intent(in) :: timestep @@ -222,7 +223,6 @@ subroutine sfc_nst_run & & rho_a, theta1, tv1, wndmag real(kind=kind_phys) elocp,tem,cpinv,hvapi - real(kind=kind_phys) windref ! ! nstm related prognostic fields ! @@ -259,11 +259,28 @@ subroutine sfc_nst_run & real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 ! + + integer ii + real(kind=kind_phys) :: ssumax, ssvmax + real(kind=kind_phys) :: windrel + logical :: check_ssu_ssv !====================================================================================================== cc ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + check_ssu_ssv=.true. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + enddo + print*, 'in sfc_nst ssumax,ssvmax =',ssumax,ssvmax + print*, 'in sfc_nst wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + endif + !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. if (nstf_name1 == 0) return ! No NSST model used @@ -310,9 +327,7 @@ subroutine sfc_nst_run & ! qss is saturation specific humidity at the water surface !! do i = 1, im -! windref = wind(i) if ( flag(i) ) then - windref = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) @@ -337,9 +352,10 @@ subroutine sfc_nst_run & ! --- ... rcp = rho cp ch v - rch(i) = rho_a(i) * cp * ch(i) * windref - cmm(i) = cm (i) * windref - chh(i) = rho_a(i) * ch(i) * windref + windrel = sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + rch(i) = rho_a(i) * cp * ch(i) * windrel + cmm(i) = cm (i) * windrel + chh(i) = rho_a(i) * ch(i) * windrel !> - Calculate latent and sensible heat flux over open water with tskin. ! at previous time step diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 2423bd8d9..7e3c7c46a 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -135,10 +135,14 @@ subroutine sfc_ocean_run & ! --- locals: real (kind=kind_phys) :: qss, rch, tem, - & elocp, cpinv, hvapi, windref + & elocp, cpinv, hvapi, windrel real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i + integer :: ii + real (kind=kind_phys) :: ssumax,ssvmax + !logical,save :: check_ssu_ssv=.true. + logical :: check_ssu_ssv logical :: flag(im) ! @@ -159,7 +163,16 @@ subroutine sfc_ocean_run & ! -- ... initialize CCPP error handling variables errmsg = '' errflg = 0 - print *, 'ssu ssv',ssu(1),ssv(1) + check_ssu_ssv=.false. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do ii=1,im + if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) + if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + enddo + print *, 'in sfc_ocean ssumax ssvmax',ssumax, ssvmax + endif cpinv = one/cp hvapi = one/hvap @@ -172,15 +185,14 @@ subroutine sfc_ocean_run & ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface -! windref = wind(i) if ( flag(i) ) then - windref = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) if (use_med_flux) then + windrel = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) q0(i) = max( q1(i), qmin ) rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) - tem = ch(i) * windref - cmm(i) = cm(i) * windref + tem = ch(i) * windrel + cmm(i) = cm(i) * windrel chh(i) = rho(i) * tem hflx(i) = dtsfc_med(i) @@ -197,9 +209,10 @@ subroutine sfc_ocean_run & ! --- ... rcp = rho cp ch v - rch = rho(i) * cp * ch(i) * windref - tem = ch(i) * windref - cmm(i) = cm(i) * windref + windrel = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) + rch = rho(i) * cp * ch(i) * windrel + tem = ch(i) * windrel + cmm(i) = cm(i) * windrel chh(i) = rho(i) * tem !> - Calcualte sensible and latent heat flux over open water diff --git a/z b/z deleted file mode 100644 index c1bc228c7..000000000 --- a/z +++ /dev/null @@ -1,16 +0,0 @@ -[ssu] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ssv] - standard_name = ocn_current_merid - long_name = ocn_current_merid - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in From cf408aa7c740e2dca1cf2140ec2c261d1a1b8af3 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Mon, 27 Nov 2023 10:27:31 +0000 Subject: [PATCH 38/64] Update sfc_diff.meta --- physics/sfc_diff.meta | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 95e2bce81..7f0139ab6 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -217,6 +217,22 @@ type = real kind = kind_phys intent = in +[u1] + standard_name = x_wind_at_surface_adjacent_layer + long_name = x component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[v1] + standard_name = y_wind_at_surface_adjacent_layer + long_name = y component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in [ssu] standard_name = ocn_current_zonal long_name = ocn_current_zonal From 562377cc0b337f8f335eb5eec2b68ea3e9ec74e6 Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 28 Nov 2023 15:30:10 -0500 Subject: [PATCH 39/64] remove files from old version --- physics/GFS_ccpp_suite_sim_pre.F90 | 442 ----------------------- physics/GFS_ccpp_suite_sim_pre.meta | 174 --------- physics/ccpp_suite_simulator.F90 | 212 ----------- physics/ccpp_suite_simulator.meta | 201 ----------- physics/module_ccpp_suite_simulator.F90 | 328 ----------------- physics/module_ccpp_suite_simulator.meta | 24 -- 6 files changed, 1381 deletions(-) delete mode 100644 physics/GFS_ccpp_suite_sim_pre.F90 delete mode 100644 physics/GFS_ccpp_suite_sim_pre.meta delete mode 100644 physics/ccpp_suite_simulator.F90 delete mode 100644 physics/ccpp_suite_simulator.meta delete mode 100644 physics/module_ccpp_suite_simulator.F90 delete mode 100644 physics/module_ccpp_suite_simulator.meta diff --git a/physics/GFS_ccpp_suite_sim_pre.F90 b/physics/GFS_ccpp_suite_sim_pre.F90 deleted file mode 100644 index fbaf5a1d9..000000000 --- a/physics/GFS_ccpp_suite_sim_pre.F90 +++ /dev/null @@ -1,442 +0,0 @@ -! ######################################################################################## -! -! Description: Interstitial CCPP suite to couple UFS physics to ccpp_suite_simulator. -! -! Contains: -! - load_ccpp_suite_sim(): read and load data into type used by ccpp_suite_simulator. -! called once during model initialization -! - GFS_ccpp_suite_sim_pre_run(): prepare GFS diagnostic physics tendencies for -! ccpp_suite_simulator. -! -! ######################################################################################## -module GFS_ccpp_suite_sim_pre - use machine, only: kind_phys - use module_ccpp_suite_simulator, only: base_physics_process - use netcdf - implicit none - public GFS_ccpp_suite_sim_pre_run, load_ccpp_suite_sim -contains - - ! ###################################################################################### - ! - ! SUBROUTINE GFS_ccpp_suite_sim_pre_run - ! - ! ###################################################################################### -!! \section arg_table_GFS_ccpp_suite_sim_pre_run -!! \htmlinclude GFS_ccpp_suite_sim_pre_run.html -!! - subroutine GFS_ccpp_suite_sim_pre_run(do_ccpp_suite_sim, dtend, ntqv, dtidx, dtp, & - index_of_process_dcnv, index_of_process_longwave, index_of_process_shortwave, & - index_of_process_scnv, index_of_process_orographic_gwd, index_of_process_pbl, & - index_of_process_mp, index_of_temperature, index_of_x_wind, index_of_y_wind, & - physics_process, iactive_T, iactive_u, iactive_v, iactive_q, active_phys_tend, & - errmsg, errflg) - - ! Inputs - logical, intent(in) :: do_ccpp_suite_sim - integer, intent(in) :: ntqv, index_of_process_dcnv, index_of_process_longwave, & - index_of_process_shortwave, index_of_process_scnv, & - index_of_process_orographic_gwd, index_of_process_pbl, index_of_process_mp, & - index_of_temperature, index_of_x_wind, index_of_y_wind - integer, intent(in), dimension(:,:) :: dtidx - real(kind_phys), intent(in) :: dtp - real(kind_phys), intent(in), dimension(:,:,:) :: dtend - type(base_physics_process),intent(in) :: physics_process(:) - integer, intent(in) :: iactive_T, iactive_u, iactive_v, iactive_q - - ! Outputs - real(kind_phys), intent(out) :: active_phys_tend(:,:,:) - character(len=*),intent(out) :: errmsg - integer, intent(out) :: errflg - - ! Locals - integer :: idtend, iactive - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. do_ccpp_suite_sim) return - - ! Get tendency for "active" process. - - ! ###################################################################################### - ! DJS2023: For the UFS and SCM, the physics tendencies are stored in a multi-dimensional - ! array, CCPP standard_name = cumulative_change_of_state_variables. - ! These are not the instantaneous physics tendencies that are applied to the state by - ! the physics suites. Not all suites output physics tendencies... - ! Rather these are intended for diagnostic puposes and are accumulated over some - ! interval. - ! In the UFS/SCM this is controlled by the diagnostic bucket interval, namelist option - ! "fhzero". For this to work, you need to clear the diagnostic buckets after each - ! physics timestep when running in the UFS/SCM. - ! - ! In the SCM this is done by adding the following runtime options: - ! --n_itt_out 1 --n_itt_diag 1 - ! - ! ###################################################################################### - if (physics_process(1)%active_name == "LWRAD") iactive = index_of_process_longwave - if (physics_process(1)%active_name == "SWRAD") iactive = index_of_process_shortwave - if (physics_process(1)%active_name == "PBL") iactive = index_of_process_pbl - if (physics_process(1)%active_name == "GWD") iactive = index_of_process_orographic_gwd - if (physics_process(1)%active_name == "SCNV") iactive = index_of_process_scnv - if (physics_process(1)%active_name == "DCNV") iactive = index_of_process_dcnv - if (physics_process(1)%active_name == "cldMP") iactive = index_of_process_mp - - ! Heat - idtend = dtidx(index_of_temperature,iactive) - if (idtend >= 1) then - active_phys_tend(:,:,iactive_T) = dtend(:,:,idtend)/dtp - endif - - ! u-wind - idtend = dtidx(index_of_x_wind,iactive) - if (idtend >= 1) then - active_phys_tend(:,:,iactive_u) = dtend(:,:,idtend)/dtp - endif - - ! v-wind - idtend = dtidx(index_of_y_wind,iactive) - if (idtend >= 1) then - active_phys_tend(:,:,iactive_v) = dtend(:,:,idtend)/dtp - endif - - ! Moisture - idtend = dtidx(100+ntqv,iactive) - if (idtend >= 1) then - active_phys_tend(:,:,iactive_q) = dtend(:,:,idtend)/dtp - endif - - end subroutine GFS_ccpp_suite_sim_pre_run - - ! ###################################################################################### - subroutine load_ccpp_suite_sim(nlunit, nml_file, physics_process, iactive_T, & - iactive_u, iactive_v, iactive_q, errmsg, errflg) - - ! Inputs - integer, intent (in) :: nlunit - character(len=*), intent (in) :: nml_file - - ! Outputs - type(base_physics_process),intent(inout),allocatable :: physics_process(:) - integer, intent(inout) :: iactive_T, iactive_u, iactive_v, iactive_q - integer, intent(out) :: errflg - character(len=256), intent(out) :: errmsg - - ! Local variables - integer :: ncid, dimID, varID, status, ios, iprc, nlev_data, ntime_data - character(len=256) :: suite_sim_file - logical :: exists, do_ccpp_suite_sim - integer :: nprc_sim - - ! For each process there is a corresponding namelist entry, which is constructed as - ! follows: - ! {use_suite_sim[0(no)/1(yes)], time_split[0(no)/1(yes)], order[1:nPhysProcess]} - integer, dimension(3) :: & - prc_LWRAD_cfg = (/0,0,0/), & - prc_SWRAD_cfg = (/0,0,0/), & - prc_PBL_cfg = (/0,0,0/), & - prc_GWD_cfg = (/0,0,0/), & - prc_SCNV_cfg = (/0,0,0/), & - prc_DCNV_cfg = (/0,0,0/), & - prc_cldMP_cfg = (/0,0,0/) - - ! Namelist - namelist / ccpp_suite_sim_nml / do_ccpp_suite_sim, suite_sim_file, nprc_sim, & - prc_LWRAD_cfg, prc_SWRAD_cfg, prc_PBL_cfg, prc_GWD_cfg, prc_SCNV_cfg, & - prc_DCNV_cfg, prc_cldMP_cfg - - errmsg = '' - errflg = 0 - - ! Read in namelist - inquire (file = trim (nml_file), exist = exists) - if (.not. exists) then - errmsg = 'CCPP suite simulator namelist file: '//trim(nml_file)//' does not exist.' - errflg = 1 - return - else - open (unit = nlunit, file = nml_file, action = 'read', status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = ccpp_suite_sim_nml, iostat=status) - close (nlunit) - - ! Only proceed if suite simulator requested. - if (prc_SWRAD_cfg(1) == 1 .or. prc_LWRAD_cfg(1) == 1 .or. prc_PBL_cfg(1) == 1 .or. & - prc_GWD_cfg(1) == 1 .or. prc_SCNV_cfg(1) == 1 .or. prc_DCNV_cfg(1) == 1 .or. & - prc_cldMP_cfg(1) == 1 ) then - else - return - endif - - ! Check that input data file exists. - inquire (file = trim (suite_sim_file), exist = exists) - if (.not. exists) then - errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not exist' - errflg = 1 - return - endif - - ! - ! Read data file... - ! - - ! Open file - status = nf90_open(trim(suite_sim_file), NF90_NOWRITE, ncid) - if (status /= nf90_noerr) then - errmsg = 'Error reading in CCPP suite simulator file: '//trim(suite_sim_file) - errflg = 1 - return - endif - - ! Metadata (dimensions) - status = nf90_inq_dimid(ncid, 'time', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = ntime_data) - else - errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not contain [time] dimension' - errflg = 1 - return - endif - - status = nf90_inq_dimid(ncid, 'lev', dimid) - if (status == nf90_noerr) then - status = nf90_inquire_dimension(ncid, dimid, len = nlev_data) - else - errmsg = 'CCPP suite simulator file: '//trim(suite_sim_file)//' does not contain [lev] dimension' - errflg = 1 - return - endif - - ! Allocate space and read in data - allocate(physics_process(nprc_sim)) - physics_process(1)%active_name = '' - physics_process(1)%iactive_scheme = 0 - physics_process(1)%active_tsp = .false. - do iprc = 1,nprc_sim - allocate(physics_process(iprc)%tend1d%T( nlev_data )) - allocate(physics_process(iprc)%tend1d%u( nlev_data )) - allocate(physics_process(iprc)%tend1d%v( nlev_data )) - allocate(physics_process(iprc)%tend1d%q( nlev_data )) - allocate(physics_process(iprc)%tend2d%time( ntime_data)) - allocate(physics_process(iprc)%tend2d%T( nlev_data, ntime_data)) - allocate(physics_process(iprc)%tend2d%u( nlev_data, ntime_data)) - allocate(physics_process(iprc)%tend2d%v( nlev_data, ntime_data)) - allocate(physics_process(iprc)%tend2d%q( nlev_data, ntime_data)) - - ! Temporal info - status = nf90_inq_varid(ncid, 'times', varID) - if (status == nf90_noerr) then - status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%time) - else - errmsg = 'SCM data tendency file: '//trim(suite_sim_file)//' does not contain times variable' - errflg = 1 - return - endif - - if (iprc == prc_SWRAD_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SWRAD" - if (prc_SWRAD_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 1 - iactive_T = 1 - endif - if (prc_SWRAD_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_swrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - endif - - if (iprc == prc_LWRAD_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "LWRAD" - if (prc_LWRAD_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 1 - iactive_T = 1 - endif - if (prc_LWRAD_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_lwrad', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - endif - - if (iprc == prc_GWD_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "GWD" - if (prc_GWD_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 3 - iactive_T = 1 - iactive_u = 2 - iactive_v = 3 - endif - if (prc_GWD_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - status = nf90_inq_varid(ncid, 'du_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) - status = nf90_inq_varid(ncid, 'dv_dt_cgwd', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - endif - - if (iprc == prc_PBL_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "PBL" - if (prc_PBL_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 4 - iactive_T = 1 - iactive_u = 2 - iactive_v = 3 - iactive_q = 4 - endif - if (prc_PBL_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - status = nf90_inq_varid(ncid, 'dq_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - status = nf90_inq_varid(ncid, 'du_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) - status = nf90_inq_varid(ncid, 'dv_dt_pbl', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - endif - - if (iprc == prc_SCNV_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "SCNV" - if (prc_SCNV_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 4 - iactive_T = 1 - iactive_u = 2 - iactive_v = 3 - iactive_q = 4 - endif - if (prc_SCNV_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - status = nf90_inq_varid(ncid, 'du_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) - status = nf90_inq_varid(ncid, 'dv_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - status = nf90_inq_varid(ncid, 'dq_dt_shalconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - endif - - if (iprc == prc_DCNV_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "DCNV" - if (prc_DCNV_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 4 - iactive_T = 1 - iactive_u = 2 - iactive_v = 3 - iactive_q = 4 - endif - if (prc_DCNV_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - status = nf90_inq_varid(ncid, 'du_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%u) - status = nf90_inq_varid(ncid, 'dv_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%v) - status = nf90_inq_varid(ncid, 'dq_dt_deepconv', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - endif - - if (iprc == prc_cldMP_cfg(3)) then - ! Metadata - physics_process(iprc)%order = iprc - physics_process(iprc)%name = "cldMP" - if (prc_cldMP_cfg(1) == 1) then - physics_process(iprc)%use_sim = .true. - else - physics_process(1)%nprg_active = 2 - iactive_T = 1 - iactive_q = 2 - endif - if (prc_cldMP_cfg(2) == 1) then - physics_process(iprc)%time_split = .true. - endif - - ! Data - status = nf90_inq_varid(ncid, 'dT_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%T) - status = nf90_inq_varid(ncid, 'dq_dt_micro', varID) - if (status == nf90_noerr) status = nf90_get_var( ncid, varID, physics_process(iprc)%tend2d%q) - endif - - ! Which process-suite is "active"? Is process time-split? - if (.not. physics_process(iprc)%use_sim) then - physics_process(1)%iactive_scheme = iprc - physics_process(1)%active_name = physics_process(iprc)%name - if (physics_process(iprc)%time_split) then - physics_process(1)%active_tsp = .true. - endif - endif - - enddo - - if (physics_process(1)%iactive_scheme == 0) then - errflg = 1 - errmsg = "ERROR: No active suite set for CCPP suite simulator" - return - endif - - print*, "-----------------------------------" - print*, "--- Using CCPP suite simulator ---" - print*, "-----------------------------------" - do iprc = 1,nprc_sim - if (physics_process(iprc)%use_sim) then - print*," simulate_suite: ", trim(physics_process(iprc)%name) - print*," order: ", physics_process(iprc)%order - print*," time_split: ", physics_process(iprc)%time_split - else - print*, " active_suite: ", trim(physics_process(1)%active_name) - print*, " order: ", physics_process(physics_process(1)%iactive_scheme)%order - print*, " time_split : ", physics_process(1)%active_tsp - endif - enddo - print*, "-----------------------------------" - print*, "-----------------------------------" - - end subroutine load_ccpp_suite_sim - -end module GFS_ccpp_suite_sim_pre diff --git a/physics/GFS_ccpp_suite_sim_pre.meta b/physics/GFS_ccpp_suite_sim_pre.meta deleted file mode 100644 index cc73813fa..000000000 --- a/physics/GFS_ccpp_suite_sim_pre.meta +++ /dev/null @@ -1,174 +0,0 @@ -[ccpp-table-properties] - name = GFS_ccpp_suite_sim_pre - type = scheme - dependencies = machine.F,module_ccpp_suite_simulator.F90 - -######################################################################## -[ccpp-arg-table] - name = GFS_ccpp_suite_sim_pre_run - type = scheme -[do_ccpp_suite_sim] - standard_name = flag_for_ccpp_suite_simulator - long_name = flag for ccpp suite simulator - units = flag - dimensions = () - type = logical - intent = in -[physics_process] - standard_name = physics_process_type_for_CCPP_suite_simulator - long_name = physics process type for CCPP suite simulator - units = mixed - dimensions = (number_of_physics_process_in_CCPP_suite_simulator) - type = base_physics_process - intent = in -[dtend] - standard_name = cumulative_change_of_state_variables - long_name = diagnostic tendencies for state variables - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,cumulative_change_of_state_variables_outer_index_max) - type = real - kind = kind_phys - intent = in -[dtidx] - standard_name = cumulative_change_of_state_variables_outer_index - long_name = index of state-variable and process in last dimension of diagnostic tendencies array AKA cumulative_change_index - units = index - dimensions = (number_of_tracers_plus_one_hundred,number_of_cumulative_change_processes) - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[index_of_process_dcnv] - standard_name = index_of_deep_convection_process_process_in_cumulative_change_index - long_name = index of deep convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_longwave] - standard_name = index_of_longwave_heating_process_in_cumulative_change_index - long_name = index of longwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_shortwave] - standard_name = index_of_shortwave_heating_process_in_cumulative_change_index - long_name = index of shortwave heating process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_orographic_gwd] - standard_name = index_of_orographic_gravity_wave_drag_process_in_cumulative_change_index - long_name = index of orographic gravity wave drag process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_scnv] - standard_name = index_of_shallow_convection_process_process_in_cumulative_change_index - long_name = index of shallow convection process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_pbl] - standard_name = index_of_subgrid_scale_vertical_mixing_process_in_cumulative_change_index - long_name = index of subgrid scale vertical mixing process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_process_mp] - standard_name = index_of_microphysics_process_process_in_cumulative_change_index - long_name = index of microphysics transport process in second dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_temperature] - standard_name = index_of_temperature_in_cumulative_change_index - long_name = index of temperature in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_x_wind] - standard_name = index_of_x_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[index_of_y_wind] - standard_name = index_of_y_wind_in_cumulative_change_index - long_name = index of x-wind in first dimension of array cumulative change index - units = index - dimensions = () - type = integer - intent = in -[ntqv] - standard_name = index_of_specific_humidity_in_tracer_concentration_array - long_name = tracer index for water vapor (specific humidity) - units = index - dimensions = () - type = integer - intent = in -[active_phys_tend] - standard_name = tendencies_for_active_process_in_ccpp_suite_simulator - long_name = tendencies for active physics process in ccpp suite simulator - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_suite_simulator) - type = real - kind = kind_phys - intent = out -[iactive_T] - standard_name = index_for_active_T_in_CCPP_suite_simulator - long_name = index into active process tracer array for temperature in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_u] - standard_name = index_for_active_u_in_CCPP_suite_simulator - long_name = index into active process tracer array for zonal wind in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_v] - standard_name = index_for_active_v_in_CCPP_suite_simulator - long_name = index into active process tracer array for meridional wind in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_q] - standard_name = index_for_active_q_in_CCPP_suite_simulator - long_name = index into active process tracer array for moisture in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out \ No newline at end of file diff --git a/physics/ccpp_suite_simulator.F90 b/physics/ccpp_suite_simulator.F90 deleted file mode 100644 index c1592263d..000000000 --- a/physics/ccpp_suite_simulator.F90 +++ /dev/null @@ -1,212 +0,0 @@ -! ######################################################################################## -! -! Description: This suite simulates the evolution of the internal physics state -! represented by a CCPP Suite Definition File (SDF). -! -! To activate this suite it must be a) embedded within the SDF and b) activated through -! the physics namelist. -! The derived-data type "base_physics_process" contains the metadata needed to reconstruct -! the temporal evolution of the state. An array of base_physics_process, physics_process, -! is populated by the host during initialization and passed to the physics. Additionally, -! this type holds any data, or type-bound procedures, required by the suite simulator(s). -! -! For this initial demonstration we are using 2-dimensional (height, time) forcing data, -! which is on the same native vertical grid as the SCM. The dataset has a temporal -! resolution of 1-hour, created by averaging all local times from a Tropical Warm Pool -! International Cloud Experiment (TWPICE) case. This was to create a dataset with a -! (constant) diurnal cycle. -! -! ######################################################################################## -module ccpp_suite_simulator - use machine, only: kind_phys - use module_ccpp_suite_simulator, only: base_physics_process, sim_LWRAD, sim_SWRAD, & - sim_PBL, sim_GWD, sim_DCNV, sim_SCNV, sim_cldMP - implicit none - public ccpp_suite_simulator_run -contains - - ! ###################################################################################### - ! - ! SUBROUTINE ccpp_suite_simulator_run - ! - ! ###################################################################################### -!! \section arg_table_ccpp_suite_simulator_run -!! \htmlinclude ccpp_suite_simulator_run.html -!! - subroutine ccpp_suite_simulator_run(do_ccpp_suite_sim, kdt, nCol, nLay, dtp, jdat, & - iactive_T, iactive_u, iactive_v, iactive_q, proc_start, proc_end, physics_process,& - in_pre_active, in_post_active, tgrs, ugrs, vgrs, qgrs, active_phys_tend, gt0, gu0,& - gv0, gq0, errmsg, errflg) - - ! Inputs - logical, intent(in) :: do_ccpp_suite_sim - integer, intent(in) :: kdt, nCol, nLay, jdat(8), iactive_T, iactive_u, & - iactive_v, iactive_q - real(kind_phys), intent(in) :: dtp, tgrs(:,:), ugrs(:,:), vgrs(:,:), qgrs(:,:,:), & - active_phys_tend(:,:,:) - ! Outputs - type(base_physics_process),intent(inout) :: physics_process(:) - real(kind_phys), intent(inout) :: gt0(:,:), gu0(:,:), gv0(:,:), gq0(:,:) - character(len=*),intent(out) :: errmsg - integer, intent(out) :: errflg - integer, intent(inout) :: proc_start, proc_end - logical, intent(inout) :: in_pre_active, in_post_active - - ! Locals - integer :: iCol, year, month, day, hour, min, sec, iprc - real(kind_phys), dimension(nCol,nLay) :: gt1, gu1, gv1, dTdt, dudt, dvdt, gq1, dqdt - - ! Initialize CCPP error handling variables - errmsg = '' - errflg = 0 - - if (.not. do_ccpp_suite_sim) return - - ! Current forecast time (Data-format specific) - year = jdat(1) - month = jdat(2) - day = jdat(3) - hour = jdat(5) - min = jdat(6) - sec = jdat(7) - - ! Set state at beginning of the physics timestep. - gt1(:,:) = tgrs(:,:) - gu1(:,:) = ugrs(:,:) - gv1(:,:) = vgrs(:,:) - gq1(:,:) = qgrs(:,:,1) - dTdt(:,:) = 0. - dudt(:,:) = 0. - dvdt(:,:) = 0. - dqdt(:,:) = 0. - - ! - ! Set bookeeping indices - ! - if (in_pre_active) then - proc_start = 1 - proc_end = max(1,physics_process(1)%iactive_scheme-1) - endif - if (in_post_active) then - proc_start = physics_process(1)%iactive_scheme - proc_end = size(physics_process) - endif - - ! - ! Simulate internal physics timestep evolution. - ! - do iprc = proc_start,proc_end - do iCol = 1,nCol - - ! Reset locals - physics_process(iprc)%tend1d%T(:) = 0. - physics_process(iprc)%tend1d%u(:) = 0. - physics_process(iprc)%tend1d%v(:) = 0. - physics_process(iprc)%tend1d%q(:) = 0. - - ! Using scheme simulator - ! Very simple... - ! Interpolate 2D data (time,level) tendency to local time. - ! Here the data is already on the SCM vertical coordinate. - ! - ! In theory the data can be of any dimensionality and the onus falls on the - ! developer to extend the type "base_physics_process" to work with for their - ! application. - ! - if (physics_process(iprc)%use_sim) then - if (physics_process(iprc)%name == "LWRAD") then - call sim_LWRAD(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "SWRAD")then - call sim_SWRAD(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "GWD")then - call sim_GWD(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "PBL")then - call sim_PBL(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "SCNV")then - call sim_SCNV(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "DCNV")then - call sim_DCNV(year, month, day, hour, min, sec, physics_process(iprc)) - endif - if (physics_process(iprc)%name == "cldMP")then - call sim_cldMP(year, month, day, hour, min, sec, physics_process(iprc)) - endif - - ! Using data tendency from "active" scheme(s). - else - if (iactive_T > 0) physics_process(iprc)%tend1d%T = active_phys_tend(iCol,:,iactive_T) - if (iactive_u > 0) physics_process(iprc)%tend1d%u = active_phys_tend(iCol,:,iactive_u) - if (iactive_v > 0) physics_process(iprc)%tend1d%v = active_phys_tend(iCol,:,iactive_v) - if (iactive_q > 0) physics_process(iprc)%tend1d%q = active_phys_tend(iCol,:,iactive_q) - endif - - ! Update state now? (time-split scheme) - if (physics_process(iprc)%time_split) then - gt1(iCol,:) = gt1(iCol,:) + (dTdt(iCol,:) + physics_process(iprc)%tend1d%T)*dtp - gu1(iCol,:) = gu1(iCol,:) + (dudt(iCol,:) + physics_process(iprc)%tend1d%u)*dtp - gv1(iCol,:) = gv1(iCol,:) + (dvdt(iCol,:) + physics_process(iprc)%tend1d%v)*dtp - gq1(iCol,:) = gq1(iCol,:) + (dqdt(iCol,:) + physics_process(iprc)%tend1d%q)*dtp - dTdt(iCol,:) = 0. - dudt(iCol,:) = 0. - dvdt(iCol,:) = 0. - dqdt(iCol,:) = 0. - ! Accumulate tendencies, update later? (process-split scheme) - else - dTdt(iCol,:) = dTdt(iCol,:) + physics_process(iprc)%tend1d%T - dudt(iCol,:) = dudt(iCol,:) + physics_process(iprc)%tend1d%u - dvdt(iCol,:) = dvdt(iCol,:) + physics_process(iprc)%tend1d%v - dqdt(iCol,:) = dqdt(iCol,:) + physics_process(iprc)%tend1d%q - endif - enddo ! END: Loop over columns - - ! Print diagnostics - if (physics_process(iprc)%use_sim) then - if (physics_process(iprc)%time_split) then - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'time split scheme (simulated)' - else - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'process split scheme (simulated)' - endif - else - if (physics_process(iprc)%time_split) then - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'time split scheme (active)' - else - write(*,'(a25,i2,a4,i2,a5,a10,a35)') 'CCPP suite simulator: ',iprc,' of ',proc_end,' ',physics_process(iprc)%name,'process split scheme (active)' - endif - write(*,'(a25,i2)') ' # prog. vars.: ',physics_process(1)%nprg_active - endif - enddo ! END: Loop over physics processes - - ! - ! Update state with accumulated tendencies (process-split only) - ! (Suites where active scheme is last physical process) - ! - iprc = minval([iprc,proc_end]) - if (.not. physics_process(iprc)%time_split) then - do iCol = 1,nCol - gt0(iCol,:) = gt1(iCol,:) + dTdt(iCol,:)*dtp - gu0(iCol,:) = gu1(iCol,:) + dudt(iCol,:)*dtp - gv0(iCol,:) = gv1(iCol,:) + dvdt(iCol,:)*dtp - gq0(iCol,:) = gq1(iCol,:) + dqdt(iCol,:)*dtp - enddo - endif - - ! - ! Update bookeeping indices - ! - if (in_pre_active) then - in_pre_active = .false. - in_post_active = .true. - endif - - if (size(physics_process) == proc_end) then - in_pre_active = .true. - in_post_active = .false. - endif - - end subroutine ccpp_suite_simulator_run - -end module ccpp_suite_simulator diff --git a/physics/ccpp_suite_simulator.meta b/physics/ccpp_suite_simulator.meta deleted file mode 100644 index bfa664922..000000000 --- a/physics/ccpp_suite_simulator.meta +++ /dev/null @@ -1,201 +0,0 @@ -[ccpp-table-properties] - name = ccpp_suite_simulator - type = scheme - dependencies = machine.F,module_ccpp_suite_simulator.F90 - -[ccpp-arg-table] - name = ccpp_suite_simulator_run - type = scheme -[do_ccpp_suite_sim] - standard_name = flag_for_ccpp_suite_simulator - long_name = flag for ccpp suite simulator - units = flag - dimensions = () - type = logical - intent = in -[kdt] - standard_name = index_of_timestep - long_name = current forecast iteration - units = index - dimensions = () - type = integer - intent = in -[nCol] - standard_name = horizontal_loop_extent - long_name = horizontal dimension - units = count - dimensions = () - type = integer - intent = in -[nLay] - standard_name = vertical_layer_dimension - long_name = number of vertical levels - units = count - dimensions = () - type = integer - intent = in -[dtp] - standard_name = timestep_for_physics - long_name = physics timestep - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[jdat] - standard_name = date_and_time_of_forecast_in_united_states_order - long_name = current forecast date and time - units = none - dimensions = (8) - type = integer - intent = in -[proc_start] - standard_name = index_for_first_physics_process_in_CCPP_suite_simulator - long_name = index for first physics process in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = inout -[proc_end] - standard_name = index_for_last_physics_process_in_CCPP_suite_simulator - long_name = index for last physics process in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = inout -[in_pre_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_before_active_scheme - long_name = flag to indicate location in physics process loop before active scheme - units = flag - dimensions = () - type = logical - intent = inout -[in_post_active] - standard_name = flag_to_indicate_location_in_physics_process_loop_after_active_scheme - long_name = flag to indicate location in physics process loop after active scheme - units = flag - dimensions = () - type = logical - intent = inout -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[ugrs] - standard_name = x_wind - long_name = zonal wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[vgrs] - standard_name = y_wind - long_name = meridional wind - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in -[qgrs] - standard_name = tracer_concentration - long_name = model layer mean tracer concentration - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_tracers) - type = real - kind = kind_phys - intent = in -[active_phys_tend] - standard_name = tendencies_for_active_process_in_ccpp_suite_simulator - long_name = tendencies for active physics process in ccpp suite simulator - units = mixed - dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_prognostics_varaibles_in_CCPP_suite_simulator) - type = real - kind = kind_phys - intent = in -[iactive_T] - standard_name = index_for_active_T_in_CCPP_suite_simulator - long_name = index into active process tracer array for temperature in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_u] - standard_name = index_for_active_u_in_CCPP_suite_simulator - long_name = index into active process tracer array for zonal wind in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_v] - standard_name = index_for_active_v_in_CCPP_suite_simulator - long_name = index into active process tracer array for meridional wind in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[iactive_q] - standard_name = index_for_active_q_in_CCPP_suite_simulator - long_name = index into active process tracer array for moisture in CCPP suite simulator - units = count - dimensions = () - type = integer - intent = in -[gt0] - standard_name = air_temperature_of_new_state - long_name = temperature updated by physics - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gu0] - standard_name = x_wind_of_new_state - long_name = zonal wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gv0] - standard_name = y_wind_of_new_state - long_name = meridional wind updated by physics - units = m s-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[gq0] - standard_name = specific_humidity_of_new_state - long_name = tracer concentration updated by physics - units = kg kg-1 - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = inout -[physics_process] - standard_name = physics_process_type_for_CCPP_suite_simulator - long_name = physics process type for CCPP suite simulator - units = mixed - dimensions = (number_of_physics_process_in_CCPP_suite_simulator) - type = base_physics_process - intent = inout -[errmsg] - standard_name = ccpp_error_message - long_name = error message for error handling in CCPP - units = none - dimensions = () - type = character - kind = len=* - intent = out -[errflg] - standard_name = ccpp_error_code - long_name = error code for error handling in CCPP - units = 1 - dimensions = () - type = integer - intent = out \ No newline at end of file diff --git a/physics/module_ccpp_suite_simulator.F90 b/physics/module_ccpp_suite_simulator.F90 deleted file mode 100644 index c4f9fc4e4..000000000 --- a/physics/module_ccpp_suite_simulator.F90 +++ /dev/null @@ -1,328 +0,0 @@ -! ######################################################################################## -! -! This module contains the type, base_physics_process, and supporting subroutines needed -! by the ccpp suite simulator. -! -! ######################################################################################## -module module_ccpp_suite_simulator -!> \section arg_table_module_ccpp_suite_simulator Argument table -!! \htmlinclude module_ccpp_suite_simulator.html -!! - use machine, only : kind_phys - implicit none - - public base_physics_process - - ! Type containing 1D (time) physics tendencies. - type phys_tend_1d - real(kind_phys), dimension(:), allocatable :: T - real(kind_phys), dimension(:), allocatable :: u - real(kind_phys), dimension(:), allocatable :: v - real(kind_phys), dimension(:), allocatable :: q - real(kind_phys), dimension(:), allocatable :: p - real(kind_phys), dimension(:), allocatable :: z - end type phys_tend_1d - - ! Type containing 2D (lev,time) physics tendencies. - type phys_tend_2d - real(kind_phys), dimension(:), allocatable :: time - real(kind_phys), dimension(:,:), allocatable :: T - real(kind_phys), dimension(:,:), allocatable :: u - real(kind_phys), dimension(:,:), allocatable :: v - real(kind_phys), dimension(:,:), allocatable :: q - real(kind_phys), dimension(:,:), allocatable :: p - real(kind_phys), dimension(:,:), allocatable :: z - end type phys_tend_2d - - ! Type containing 3D (loc,lev,time) physics tendencies. - type phys_tend_3d - real(kind_phys), dimension(:), allocatable :: time - real(kind_phys), dimension(:), allocatable :: lon - real(kind_phys), dimension(:), allocatable :: lat - real(kind_phys), dimension(:,:,:), allocatable :: T - real(kind_phys), dimension(:,:,:), allocatable :: u - real(kind_phys), dimension(:,:,:), allocatable :: v - real(kind_phys), dimension(:,:,:), allocatable :: q - end type phys_tend_3d - - ! Type containing 4D (lon,lat,lev,time) physics tendencies. - type phys_tend_4d - real(kind_phys), dimension(:), allocatable :: time - real(kind_phys), dimension(:,:), allocatable :: lon - real(kind_phys), dimension(:,:), allocatable :: lat - real(kind_phys), dimension(:,:,:,:), allocatable :: T - real(kind_phys), dimension(:,:,:,:), allocatable :: u - real(kind_phys), dimension(:,:,:,:), allocatable :: v - real(kind_phys), dimension(:,:,:,:), allocatable :: q - end type phys_tend_4d - -! This type contains the meta information and data for each physics process. - -!> \section arg_table_base_physics_process Argument Table -!! \htmlinclude base_physics_process.html -!! - type base_physics_process - character(len=16) :: name ! Physics process name - logical :: time_split = .false. ! Is process time-split? - logical :: use_sim = .false. ! Is process "active"? - integer :: order ! Order of process in process-loop - type(phys_tend_1d) :: tend1d ! Instantaneous data - type(phys_tend_2d) :: tend2d ! 2-dimensional data - type(phys_tend_3d) :: tend3d ! Not used. Placeholder for 3-dimensional spatial data. - type(phys_tend_4d) :: tend4d ! Not used. Placeholder for 4-dimensional spatio-tempo data. - character(len=16) :: active_name ! "Active" scheme: Physics process name - integer :: iactive_scheme ! "Active" scheme: Order of process in process-loop - logical :: active_tsp ! "Active" scheme: Is process time-split? - integer :: nprg_active ! "Active" scheme: Number of prognostic variables - contains - generic, public :: linterp => linterp_1D, linterp_2D - procedure, private :: linterp_1D - procedure, private :: linterp_2D - procedure, public :: find_nearest_loc_2d_1d - procedure, public :: cmp_time_wts - end type base_physics_process - -contains - - ! #################################################################################### - ! Type-bound procedure to compute tendency profile for time-of-day. - ! - ! For use with 1D data (level, time) tendencies with diurnal (24-hr) forcing. - ! #################################################################################### - function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err_message) - class(base_physics_process), intent(inout) :: this - character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: err_message - integer :: ti(1), tf(1), ntime - real(kind_phys) :: w1, w2 - - ! Interpolation weights - call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) - - ntime = size(this%tend2d%T(1,:)) - - select case(var_name) - case("T") - if (tf(1) .le. ntime) then - this%tend1d%T = w1*this%tend2d%T(:,ti(1)) + w2*this%tend2d%T(:,tf(1)) - else - this%tend1d%T = this%tend2d%T(:,1) - endif - case("u") - if (tf(1) .le. ntime) then - this%tend1d%u = w1*this%tend2d%u(:,ti(1)) + w2*this%tend2d%u(:,tf(1)) - else - this%tend1d%u = this%tend2d%u(:,1) - endif - case("v") - if (tf(1) .le. ntime) then - this%tend1d%v = w1*this%tend2d%v(:,ti(1)) + w2*this%tend2d%v(:,tf(1)) - else - this%tend1d%v = this%tend2d%v(:,1) - endif - case("q") - if (tf(1) .le. ntime) then - this%tend1d%q = w1*this%tend2d%q(:,ti(1)) + w2*this%tend2d%q(:,tf(1)) - else - this%tend1d%q = this%tend2d%q(:,1) - endif - end select - - end function linterp_1D - - ! #################################################################################### - ! Type-bound procedure to compute tendency profile for time-of-day. - ! - ! For use with 2D data (location, level, time) tendencies with diurnal (24-hr) forcing. - ! This assumes that the location dimension has a [longitude, latitude] allocated with - ! each location. - ! #################################################################################### - function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) result(err_message) - class(base_physics_process), intent(inout) :: this - character(len=*), intent(in) :: var_name - integer, intent(in) :: year, month, day, hour, min, sec - real(kind_phys), intent(in) :: lon, lat - character(len=128) :: err_message - integer :: ti(1), tf(1), iNearest - real(kind_phys) :: w1, w2 - - ! Interpolation weights (temporal) - call this%cmp_time_wts(year, month, day, hour, min, sec, w1, w2, ti, tf) - - ! Grab data tendency closest to column [lon,lat] - iNearest = this%find_nearest_loc_2d_1d(lon,lat) - - select case(var_name) - case("T") - this%tend1d%T = w1*this%tend3d%T(iNearest,:,ti(1)) + w2*this%tend3d%T(iNearest,:,tf(1)) - case("u") - this%tend1d%u = w1*this%tend3d%u(iNearest,:,ti(1)) + w2*this%tend3d%u(iNearest,:,tf(1)) - case("v") - this%tend1d%v = w1*this%tend3d%v(iNearest,:,ti(1)) + w2*this%tend3d%v(iNearest,:,tf(1)) - case("q") - this%tend1d%q = w1*this%tend3d%q(iNearest,:,ti(1)) + w2*this%tend3d%q(iNearest,:,tf(1)) - end select - end function linterp_2D - - ! #################################################################################### - ! Type-bound procedure to find nearest location. - ! For use with linterp_2D, NOT YET IMPLEMENTED. - ! #################################################################################### - pure function find_nearest_loc_2d_1d(this, lon, lat) - class(base_physics_process), intent(in) :: this - real(kind_phys), intent(in) :: lon, lat - integer :: find_nearest_loc_2d_1d - - find_nearest_loc_2d_1d = 1 - end function find_nearest_loc_2d_1d - - ! #################################################################################### - ! Type-bound procedure to compute linear interpolation weights for a diurnal (24-hour) - ! forcing. - ! #################################################################################### - subroutine cmp_time_wts(this, year, month, day, hour, minute, sec, w1, w2, ti, tf) - ! Inputs - class(base_physics_process), intent(in) :: this - integer, intent(in) :: year, month, day, hour, minute, sec - ! Outputs - integer,intent(out) :: ti(1), tf(1) - real(kind_phys),intent(out) :: w1, w2 - ! Locals - real(kind_phys) :: hrofday - - hrofday = hour*3600. + minute*60. + sec - ti = max(hour,1) - tf = min(ti + 1,24) - w1 = ((hour+1)*3600 - hrofday)/3600 - w2 = 1 - w1 - - end subroutine cmp_time_wts - - ! #################################################################################### - ! #################################################################################### - subroutine sim_LWRAD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - - end subroutine sim_LWRAD - - ! #################################################################################### - ! #################################################################################### - subroutine sim_SWRAD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - - end subroutine sim_SWRAD - - ! #################################################################################### - ! #################################################################################### - subroutine sim_GWD( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - - end subroutine sim_GWD - - ! #################################################################################### - ! #################################################################################### - subroutine sim_PBL( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_PBL - - ! #################################################################################### - ! #################################################################################### - subroutine sim_DCNV( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_DCNV - - ! #################################################################################### - ! #################################################################################### - subroutine sim_SCNV( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%u)) then - errmsg = process%linterp("u", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%v)) then - errmsg = process%linterp("v", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - - end subroutine sim_SCNV - - ! #################################################################################### - ! #################################################################################### - subroutine sim_cldMP( year, month, day, hour, min, sec, process) - type(base_physics_process), intent(inout) :: process - integer, intent(in) :: year, month, day, hour, min, sec - character(len=128) :: errmsg - - if (allocated(process%tend2d%T)) then - errmsg = process%linterp("T", year,month,day,hour,min,sec) - endif - if (allocated(process%tend2d%q)) then - errmsg = process%linterp("q", year,month,day,hour,min,sec) - endif - end subroutine sim_cldMP - -end module module_ccpp_suite_simulator diff --git a/physics/module_ccpp_suite_simulator.meta b/physics/module_ccpp_suite_simulator.meta deleted file mode 100644 index cd8e3db1b..000000000 --- a/physics/module_ccpp_suite_simulator.meta +++ /dev/null @@ -1,24 +0,0 @@ -[ccpp-table-properties] - name = base_physics_process - type = ddt - dependencies = - -[ccpp-arg-table] - name = base_physics_process - type = ddt - -######################################################################## -[ccpp-table-properties] - name = module_ccpp_suite_simulator - type = module - dependencies = machine.F - -[ccpp-arg-table] - name = module_ccpp_suite_simulator - type = module -[base_physics_process] - standard_name = base_physics_process - long_name = definition of type base_physics_process - units = DDT - dimensions = () - type = base_physics_process From 12cd9c698ad9bc97bb4c84a2225542ccaf0ce3bc Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Tue, 28 Nov 2023 15:35:12 -0500 Subject: [PATCH 40/64] update files satmedmfvdifq.F samfshalcnv.f sfc_diff.f --- physics/samfshalcnv.f | 2 +- physics/satmedmfvdifq.F | 2 +- physics/scm_sfc_flux_spec.F90 | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 3869ea6ea..d0bab05dd 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -191,7 +191,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(cinacrmx=-120.,shevf=2.0) parameter(dtmax=10800.,dtmin=600.) parameter(bb1=4.0,bb2=0.8,csmf=0.2) - parameter(tkcrt=2.,cmxfac=15.) + parameter(tkcrt=2.,cmxfac=10.) ! parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 73fc4aff8..7b54b6d12 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -271,7 +271,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(elmfac=1.0,elefac=1.0,cql=100.) parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=1000.) parameter(qlcr=3.5e-5,zstblmax=2500.) - parameter(xkinv1=0.15,xkinv2=0.3) + parameter(xkinv1=0.4,xkinv2=0.3) parameter(h1=0.33333333,hcrinv=250.) parameter(vegflo=0.1,vegfup=1.0,z0lo=0.1,z0up=1.0) parameter(vc0=1.0,zc0=1.0) diff --git a/physics/scm_sfc_flux_spec.F90 b/physics/scm_sfc_flux_spec.F90 index e835b77ff..835b468ff 100644 --- a/physics/scm_sfc_flux_spec.F90 +++ b/physics/scm_sfc_flux_spec.F90 @@ -58,9 +58,9 @@ subroutine scm_sfc_flux_spec_run (im, u1, v1, z1, t1, q1, p1, roughness_length, use machine, only: kind_phys integer, intent(in) :: im, lkm - integer, intent(inout) :: islmsk(:), use_lake_model(:) + integer, intent(inout) :: islmsk(:) logical, intent(in) :: cplflx, cplice - logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:) + logical, intent(inout) :: dry(:), icy(:), flag_cice(:), wet(:), use_lake_model(:) real(kind=kind_phys), intent(in) :: cp, grav, hvap, rd, fvirt, vonKarman, min_seaice, tgice, min_lakeice real(kind=kind_phys), intent(in) :: u1(:), v1(:), z1(:), t1(:), q1(:), p1(:), roughness_length(:), & spec_sh_flux(:), spec_lh_flux(:), exner_inverse(:), T_surf(:), oceanfrac(:), lakefrac(:), lakedepth(:) From 6bdadb5e7c61f2cabe391736cb3d29e1d041b434 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 29 Nov 2023 09:47:20 +0000 Subject: [PATCH 41/64] Set check_ssu_ssv to false in the following files: satmedmfvdif.F satmedmfvdifq.F sfc_diag.f sfc_diff.f --- physics/satmedmfvdif.F | 4 +--- physics/satmedmfvdifq.F | 7 ++----- physics/sfc_diag.f | 3 +-- physics/sfc_diff.f | 3 +-- physics/sfc_nst.f | 3 +-- 5 files changed, 6 insertions(+), 14 deletions(-) diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index a0441e8f4..cc7ce95b3 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -255,18 +255,16 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & errmsg = '' errflg = 0 ! - check_ssu_ssv=.true. + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 ssvmax=0.0 do ii=1,im if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) - !windrel(ii) = sqrt((u1(ii)-ssu(ii))**2+(v1(ii)-ssv(ii))**2) enddo print*, 'in satmedmfvdif.F ssumax,ssvmax =',ssumax,ssvmax endif - !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. !> -# Compute preliminary variables from input arguments dt2 = delt diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 62bf6473f..8a200eb92 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -280,13 +280,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) -!BL integer ii real(kind=kind_phys) :: ssumax, ssvmax logical :: check_ssu_ssv - write(*,*)'in_satmedmfvdifq,u1 v1',u1(1,1),v1(1,1) - check_ssu_ssv=.true. + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 ssvmax=0.0 @@ -294,10 +292,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) enddo + write(*,*)'in_satmedmfvdifq,u1 v1',u1(1,1),v1(1,1) print*, 'in satmedmfvdifq.F ssumax,ssvmax =',ssumax,ssvmax endif - !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. -!BL if (tc_pbl == 0) then ck0 = 0.4 diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index b9006d6a9..acfad7b27 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -77,7 +77,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & errmsg = '' errflg = 0 - check_ssu_ssv=.true. + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 ssvmax=0.0 @@ -87,7 +87,6 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & enddo print*, 'in sfc_diag ssumax,ssvmax =',ssumax,ssvmax endif - !if(abs(ssumax-0.02).lt.0.01) check_ssu_ssv=.false. !-- testptlat = 35.3_kind_phys diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0ac51fda0..58614c452 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -175,7 +175,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - check_ssu_ssv=.true. + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 ssvmax=0.0 @@ -186,7 +186,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) print*, 'in sfc_diff ssumax,ssvmax =',ssumax,ssvmax print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) endif - !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. do i=1,im windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) enddo diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 8aad8fc8f..526271aa3 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -269,7 +269,7 @@ subroutine sfc_nst_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - check_ssu_ssv=.true. + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 ssvmax=0.0 @@ -280,7 +280,6 @@ subroutine sfc_nst_run & print*, 'in sfc_nst ssumax,ssvmax =',ssumax,ssvmax print*, 'in sfc_nst wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) endif - !if(abs(ssumax-0.02) .lt. 0.01) check_ssu_ssv=.false. if (nstf_name1 == 0) return ! No NSST model used From a2a242487053a091b338f4ef1f3431f3304b205e Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 29 Nov 2023 15:16:31 +0000 Subject: [PATCH 42/64] Update sfc_diff.meta --- physics/sfc_diff.meta | 7 ------- 1 file changed, 7 deletions(-) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 7f0139ab6..80a89fc1b 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -102,13 +102,6 @@ type = real kind = kind_phys intent = in -[windrel] - standard_name = relative_wind_speed_at_lowest_model_layer - long_name = relative wind speed at lowest model level - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys [prsl1] standard_name = air_pressure_at_surface_adjacent_layer long_name = Model layer 1 mean pressure From 9fb9c05dfc63c90333dafcf038a325c9e6ffe856 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 6 Dec 2023 18:44:17 +0000 Subject: [PATCH 43/64] Add a namelist option for including surface ocean current in the computation of air-sea fluxes. --- physics/satmedmfvdifq.F | 30 +++++++++++++++----------- physics/satmedmfvdifq.meta | 7 +++++++ physics/sfc_diag.f | 17 ++++++++++----- physics/sfc_diag.meta | 7 +++++++ physics/sfc_diff.f | 32 +++++++++++++++++----------- physics/sfc_diff.meta | 7 +++++++ physics/sfc_nst.f | 43 ++++++++++++++++++++++++-------------- physics/sfc_nst.meta | 7 +++++++ physics/sfc_ocean.F | 42 ++++++++++++++++++++++++------------- physics/sfc_ocean.meta | 7 +++++++ physics/zzz | 12 +++++++++++ 11 files changed, 151 insertions(+), 60 deletions(-) create mode 100755 physics/zzz diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 8a200eb92..9a2214704 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -75,8 +75,8 @@ end subroutine satmedmfvdifq_init !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,swh,hlw,xmu, & - & garea,zvfun,sigmaf, & + & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,iopt_flx_over_ocn, & + & swh,hlw,xmu,garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -127,6 +127,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(inout), dimension(:,:,:) :: dtend integer, intent(in) :: dtidx(:,:), index_of_temperature, & & index_of_x_wind, index_of_y_wind, index_of_process_pbl + integer, intent(in) :: iopt_flx_over_ocn real(kind=kind_phys), intent(out) :: & & dusfc(:), dvsfc(:), & & dtsfc(:), dqsfc(:), & @@ -143,6 +144,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !---------------------------------------------------------------------- !*** !*** local variables + real(kind=kind_phys) spd1_m(im) !*** integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1,idtend integer kps,kbx,kmx @@ -280,20 +282,20 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) - integer ii real(kind=kind_phys) :: ssumax, ssvmax logical :: check_ssu_ssv check_ssu_ssv=.false. - if(check_ssu_ssv) then + if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then ssumax=0.0 ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + do i=1,im + if(ssu(i) .gt. ssumax) ssumax=ssu(i) + if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) enddo write(*,*)'in_satmedmfvdifq,u1 v1',u1(1,1),v1(1,1) - print*, 'in satmedmfvdifq.F ssumax,ssvmax =',ssumax,ssvmax + print*, 'in satmedmfvdifq.F ssumax,ssvmax',ssumax,ssvmax + print*,'in satmedmfvdifq.F iopt_flx_over_ocn',iopt_flx_over_ocn endif if (tc_pbl == 0) then @@ -2393,10 +2395,14 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo enddo do i = 1,im -! dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) -! dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) - dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1(i) - dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1(i) + if(iopt_flx_over_ocn == 1) then + spd1_m(i)=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) + dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m(i) + else + dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + endif enddo ! if(ldiag3d .and. .not. gen_tend) then diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index b21e5d4f2..4b84d6c65 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -233,6 +233,13 @@ type = real kind = kind_phys intent = in +[iopt_flx_over_ocn] + standard_name = flag_for_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = integer + intent = in [t1] standard_name = air_temperature long_name = layer mean air temperature diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index acfad7b27..5acda6181 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -17,7 +17,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & & con_karman, & & shflx,cdq,wind, & - & ssu,ssv, & + & ssu,ssv,iopt_flx_over_ocn, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & use_lake_model,iopt_lake,iopt_lake_clm, & @@ -31,6 +31,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & implicit none ! integer, intent(in) :: im, lsm, lsm_ruc, iopt_lake, iopt_lake_clm + integer, intent(in) :: iopt_flx_over_ocn logical, intent(in) :: use_lake2m logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics @@ -78,14 +79,15 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & errflg = 0 check_ssu_ssv=.false. - if(check_ssu_ssv) then + if(check_ssu_ssv .and. iopt_flx_over_ocn ==1) then ssumax=0.0 ssvmax=0.0 do ii=1,im if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) enddo - print*, 'in sfc_diag ssumax,ssvmax =',ssumax,ssvmax + print*, 'in sfc_diag ssumax ssvmax=', ssumax, ssvmax + print*, 'in sfc_diag iopt_flx_over_ocn=', iopt_flx_over_ocn endif !-- @@ -105,8 +107,13 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) - u10m(i) = ssu(i) + f10m(i) * (u1(i)-ssu(i)) - v10m(i) = ssv(i) + f10m(i) * (v1(i)-ssv(i)) + if(iopt_flx_over_ocn ==1) then + u10m(i) = ssu(i) + f10m(i) * (u1(i)-ssu(i)) + v10m(i) = ssv(i) + f10m(i) * (v1(i)-ssv(i)) + else + u10m(i) = f10m(i) * u1(i) + v10m(i) = f10m(i) * v1(i) + endif have_2m = use_lake_model(i)>0 .and. use_lake2m .and. & & iopt_lake==iopt_lake_clm if(have_2m) then diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 9a8a5517e..834ad5871 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -139,6 +139,13 @@ type = real kind = kind_phys intent = in +[iopt_flx_over_ocn] + standard_name = flag_for_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = integer + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = 1st model layer air temperature diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 58614c452..62102151a 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,7 +61,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) - & u1,v1,ssu,ssv, & + & u1,v1,ssu,ssv,iopt_flx_over_ocn, & & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -86,6 +86,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, parameter :: kp = kind_phys integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean + integer, intent(in) :: iopt_flx_over_ocn ! option for including ocean current in the computation of flux integer, dimension(:), intent(in) :: vegtype @@ -129,10 +130,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer i integer ii real(kind=kind_phys) :: ssumax, ssvmax - real(kind=kind_phys), dimension(im) :: windrel + real(kind=kind_phys), dimension(im) :: windrel, wind10m logical :: check_ssu_ssv ! - real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, + real(kind=kind_phys) :: rat, tv1, thv1, restar, & czilc, tem1, tem2, virtfac ! @@ -176,7 +177,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) check_ssu_ssv=.false. - if(check_ssu_ssv) then + if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then ssumax=0.0 ssvmax=0.0 do ii=1,im @@ -184,11 +185,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) enddo print*, 'in sfc_diff ssumax,ssvmax =',ssumax,ssvmax + print*, 'in sfc_diff iopt_flx_over_ocn =',iopt_flx_over_ocn print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + do i=1,im + windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + wind10m(i)= sqrt( (u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2 ) + enddo + else + do i=1,im + wind10m(i)= sqrt( u10m(i)**2 + v10m(i)**2 ) + windrel(i)=wind(i) + enddo endif - do i=1,im - windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) - enddo do i=1,im if(flag_iter(i)) then @@ -375,7 +383,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0 = 0.01_kp * z0rl_wat(i) z0max = max(zmin, min(z0,z1(i))) ! ustar_wat(i) = sqrt(grav * z0 / charnock) - wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) +! wind10m = sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) !** test xubin's new z0 @@ -394,9 +402,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ztmax_wat(i) = max(z0max * exp(-rat), zmin) ! if (sfc_z0_type == 6) then - call znot_t_v6(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) + call znot_t_v6(wind10m(i), ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type == 7) then - call znot_t_v7(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) + call znot_t_v7(wind10m(i), ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type errflg = 1 @@ -437,10 +445,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + call znot_m_v6(wind10m(i), z0) ! wind, m/s, z0, m z0rl_wat(i) = 100.0_kp * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + call znot_m_v7(wind10m(i), z0) ! wind, m/s, z0, m z0rl_wat(i) = 100.0_kp * z0 ! cm else z0rl_wat(i) = 1.0e-4_kp diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 80a89fc1b..360c2a0c8 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -249,6 +249,13 @@ dimensions = () type = integer intent = in +[iopt_flx_over_ocn] + standard_name = flag_for_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = integer + intent = in [wet] standard_name = flag_nonzero_wet_surface_fraction long_name = flag indicating presence of some ocean or lake surface area fraction diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 526271aa3..92d7b9c63 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -16,8 +16,8 @@ module sfc_nst !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm subroutine sfc_nst_run & & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: - & pi, tgice, sbc, ps, u1, v1, ssu, ssv, t1, q1, tref, cm, ch,& - & lseaspray, fm, fm10, & + & pi, tgice, sbc, ps, u1, v1, ssu, ssv, iopt_flx_over_ocn, & + & t1, q1, tref, cm, ch, lseaspray, fm, fm10, & & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & & sinlat, stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & @@ -36,8 +36,8 @@ subroutine sfc_nst_run & ! ! ! call sfc_nst ! ! inputs: ! -! ( im, ps, u1, v1, ssu,ssv, t1, q1, tref, cm, ch, ! -! lseaspray, fm, fm10, ! +! ( im, ps, u1, v1, ssu,ssv, iopt_flx_over_ocn, ! +! t1, q1, tref, cm, ch, lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_lake_model, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! @@ -76,6 +76,8 @@ subroutine sfc_nst_run & ! ps - real, surface pressure (pa) im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! ssu, ssv - real, u/v component of surface current (m/s) im ! +! iopt_flx_over_ocn - integer, option to include 1 ! +! ocean current in the computation of flux ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tref - real, reference/foundation temperature ( k ) im ! @@ -182,7 +184,7 @@ subroutine sfc_nst_run & ! --- inputs: integer, intent(in) :: im, kdt, ipr, nstf_name1, nstf_name4, & - & nstf_name5 + & nstf_name5, iopt_flx_over_ocn real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & @@ -260,26 +262,35 @@ subroutine sfc_nst_run & & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 ! - integer ii real(kind=kind_phys) :: ssumax, ssvmax - real(kind=kind_phys) :: windrel - logical :: check_ssu_ssv + real(kind=kind_phys) :: windrel(im) + logical :: check_ssu_ssv !====================================================================================================== cc ! Initialize CCPP error handling variables errmsg = '' errflg = 0 check_ssu_ssv=.false. - if(check_ssu_ssv) then + if(check_ssu_ssv .and. iopt_flx_over_ocn ==1) then ssumax=0.0 ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + do i=1,im + if(ssu(i) .gt. ssumax) ssumax=ssu(i) + if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) enddo print*, 'in sfc_nst ssumax,ssvmax =',ssumax,ssvmax + print*, 'in sfc_nst iopt_flx_over_ocn =',iopt_flx_over_ocn print*, 'in sfc_nst wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) endif + if(iopt_flx_over_ocn ==1) then + do i=1,im + windrel(i) = sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + enddo + else + do i=1,im + windrel(i) = wind(i) + enddo + endif if (nstf_name1 == 0) return ! No NSST model used @@ -351,10 +362,10 @@ subroutine sfc_nst_run & ! --- ... rcp = rho cp ch v - windrel = sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) - rch(i) = rho_a(i) * cp * ch(i) * windrel - cmm(i) = cm (i) * windrel - chh(i) = rho_a(i) * ch(i) * windrel + !windrel = sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + rch(i) = rho_a(i) * cp * ch(i) * windrel(i) + cmm(i) = cm (i) * windrel(i) + chh(i) = rho_a(i) * ch(i) * windrel(i) !> - Calculate latent and sensible heat flux over open water with tskin. ! at previous time step diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 10330fbb3..eb5a2d379 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -150,6 +150,13 @@ type = real kind = kind_phys intent = in +[iopt_flx_over_ocn] + standard_name = flag_for_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = integer + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = surface layer mean temperature diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 7e3c7c46a..27e309eca 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -24,7 +24,8 @@ subroutine sfc_ocean_run & !................................... ! --- inputs: & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & - & tskin, cm, ch, lseaspray, fm, fm10, ssu, ssv, & + & tskin, cm, ch, lseaspray, fm, fm10, & + & ssu, ssv, iopt_flx_over_ocn, & & prsl1, prslki, wet, use_lake_model, wind, &, ! --- inputs & flag_iter, use_med_flux, dqsfc_med, dtsfc_med, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs @@ -39,6 +40,7 @@ subroutine sfc_ocean_run & ! call sfc_ocean ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! +! ssu, ssv, iopt_flx_over_ocn, ! ! prsl1, prslki, wet, use_lake_model, wind, flag_iter, ! ! use_med_flux, ! ! outputs: ! @@ -67,6 +69,8 @@ subroutine sfc_ocean_run & ! ps - real, surface pressure im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! ssu,ssv - real, u/v component of surface ocean current (m/s) im ! +! iopt_flx_over_ocn - integer, option for including 1 ! +! ocean current in the computation of flux ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! @@ -106,6 +110,7 @@ subroutine sfc_ocean_run & & zero = 0.0_kind_phys, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im + integer, intent(in) :: iopt_flx_over_ocn real (kind=kind_phys), intent(in) :: hvap, cp, rd, & & eps, epsm1, rvrdm1 @@ -135,11 +140,10 @@ subroutine sfc_ocean_run & ! --- locals: real (kind=kind_phys) :: qss, rch, tem, - & elocp, cpinv, hvapi, windrel + & elocp, cpinv, hvapi, windrel(im) real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i - integer :: ii real (kind=kind_phys) :: ssumax,ssvmax !logical,save :: check_ssu_ssv=.true. logical :: check_ssu_ssv @@ -164,15 +168,25 @@ subroutine sfc_ocean_run & errmsg = '' errflg = 0 check_ssu_ssv=.false. - if(check_ssu_ssv) then + if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then ssumax=0.0 ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) + do i=1,im + if(ssu(i) .gt. ssumax) ssumax=ssu(i) + if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) enddo - print *, 'in sfc_ocean ssumax ssvmax',ssumax, ssvmax + print *, 'in sfc_ocean ssumax,ssvmax',ssumax,ssvmax + print *, 'in sfc_ocean iopt_flx_over_ocn',iopt_flx_over_ocn endif + if(iopt_flx_over_ocn == 1) then + do i=1,im + windrel(i) = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) + enddo + else + do i=1,im + windrel(i) = wind(i) + enddo + endif cpinv = one/cp hvapi = one/hvap @@ -187,12 +201,11 @@ subroutine sfc_ocean_run & if ( flag(i) ) then if (use_med_flux) then - windrel = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) q0(i) = max( q1(i), qmin ) rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) - tem = ch(i) * windrel - cmm(i) = cm(i) * windrel + tem = ch(i) * windrel(i) + cmm(i) = cm(i) * windrel(i) chh(i) = rho(i) * tem hflx(i) = dtsfc_med(i) @@ -209,10 +222,9 @@ subroutine sfc_ocean_run & ! --- ... rcp = rho cp ch v - windrel = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) - rch = rho(i) * cp * ch(i) * windrel - tem = ch(i) * windrel - cmm(i) = cm(i) * windrel + rch = rho(i) * cp * ch(i) * windrel(i) + tem = ch(i) * windrel(i) + cmm(i) = cm(i) * windrel(i) chh(i) = rho(i) * tem !> - Calcualte sensible and latent heat flux over open water diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 7d2e55e27..f99d74773 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -102,6 +102,13 @@ type = real kind = kind_phys intent = in +[iopt_flx_over_ocn] + standard_name = flag_for_air_sea_flux_computation_over_water + long_name = air-sea flux option + units = flag + dimensions = () + type = integer + intent = in [t1] standard_name = air_temperature_at_surface_adjacent_layer long_name = surface layer mean temperature diff --git a/physics/zzz b/physics/zzz new file mode 100755 index 000000000..e9bd2da01 --- /dev/null +++ b/physics/zzz @@ -0,0 +1,12 @@ +#!/bin/sh +export src1=/scratch1/NCEPDEV/stmp4/Bin.Li/20231201/ufs-weather-model/FV3/ccpp/physics/physics +cp $src1/satmedmfvdifq.F . +cp $src1/satmedmfvdifq.meta . +cp $src1/sfc_diff.f . +cp $src1/sfc_diff.meta . +cp $src1/sfc_diag.f . +cp $src1/sfc_diag.meta . +cp $src1/sfc_nst.f . +cp $src1/sfc_nst.meta . +cp $src1/sfc_ocean.F . +cp $src1/sfc_ocean.meta . From 06b0563ff7483b223102f960d4845c455a90843e Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Fri, 8 Dec 2023 16:12:26 +0000 Subject: [PATCH 44/64] Revise the namelist option to include sea surface current in the computation of air-sea fluxes. --- physics/satmedmfvdifq.F | 22 +++------------------- physics/satmedmfvdifq.meta | 2 +- physics/sfc_diag.f | 21 +++------------------ physics/sfc_diag.meta | 2 +- physics/sfc_diff.f | 19 +++---------------- physics/sfc_diff.meta | 2 +- physics/sfc_nst.meta | 2 +- physics/sfc_ocean.F | 25 ++++++------------------- physics/sfc_ocean.meta | 2 +- physics/zzz | 12 ------------ 10 files changed, 20 insertions(+), 89 deletions(-) delete mode 100755 physics/zzz diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 9a2214704..55667d515 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -75,7 +75,7 @@ end subroutine satmedmfvdifq_init !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,iopt_flx_over_ocn, & + & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,icplocn2atm, & & swh,hlw,xmu,garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & @@ -127,7 +127,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(inout), dimension(:,:,:) :: dtend integer, intent(in) :: dtidx(:,:), index_of_temperature, & & index_of_x_wind, index_of_y_wind, index_of_process_pbl - integer, intent(in) :: iopt_flx_over_ocn + integer, intent(in) :: icplocn2atm real(kind=kind_phys), intent(out) :: & & dusfc(:), dvsfc(:), & & dtsfc(:), dqsfc(:), & @@ -282,22 +282,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) - real(kind=kind_phys) :: ssumax, ssvmax - logical :: check_ssu_ssv - - check_ssu_ssv=.false. - if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then - ssumax=0.0 - ssvmax=0.0 - do i=1,im - if(ssu(i) .gt. ssumax) ssumax=ssu(i) - if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) - enddo - write(*,*)'in_satmedmfvdifq,u1 v1',u1(1,1),v1(1,1) - print*, 'in satmedmfvdifq.F ssumax,ssvmax',ssumax,ssvmax - print*,'in satmedmfvdifq.F iopt_flx_over_ocn',iopt_flx_over_ocn - endif - if (tc_pbl == 0) then ck0 = 0.4 ch0 = 0.4 @@ -2395,7 +2379,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo enddo do i = 1,im - if(iopt_flx_over_ocn == 1) then + if(icplocn2atm == 1) then spd1_m(i)=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m(i) dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m(i) diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 4b84d6c65..c97126457 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -233,7 +233,7 @@ type = real kind = kind_phys intent = in -[iopt_flx_over_ocn] +[icplocn2atm] standard_name = flag_for_air_sea_flux_computation_over_water long_name = air-sea flux option units = flag diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 5acda6181..1fa7fa450 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -17,7 +17,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & & con_karman, & & shflx,cdq,wind, & - & ssu,ssv,iopt_flx_over_ocn, & + & ssu,ssv,icplocn2atm, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & use_lake_model,iopt_lake,iopt_lake_clm, & @@ -31,7 +31,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & implicit none ! integer, intent(in) :: im, lsm, lsm_ruc, iopt_lake, iopt_lake_clm - integer, intent(in) :: iopt_flx_over_ocn + integer, intent(in) :: icplocn2atm logical, intent(in) :: use_lake2m logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics @@ -70,26 +70,11 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! real(kind=kind_phys) sig2k, fhi, qss ! ! real, parameter :: g=grav - integer ii - real(kind=kind_phys) :: ssumax, ssvmax - logical :: check_ssu_ssv ! ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - check_ssu_ssv=.false. - if(check_ssu_ssv .and. iopt_flx_over_ocn ==1) then - ssumax=0.0 - ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) - enddo - print*, 'in sfc_diag ssumax ssvmax=', ssumax, ssvmax - print*, 'in sfc_diag iopt_flx_over_ocn=', iopt_flx_over_ocn - endif - !-- testptlat = 35.3_kind_phys testptlon = 273.0_kind_phys @@ -107,7 +92,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) - if(iopt_flx_over_ocn ==1) then + if(icplocn2atm ==1) then u10m(i) = ssu(i) + f10m(i) * (u1(i)-ssu(i)) v10m(i) = ssv(i) + f10m(i) * (v1(i)-ssv(i)) else diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 834ad5871..da300d053 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -139,7 +139,7 @@ type = real kind = kind_phys intent = in -[iopt_flx_over_ocn] +[icplocn2atm] standard_name = flag_for_air_sea_flux_computation_over_water long_name = air-sea flux option units = flag diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 62102151a..9c00b7040 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,7 +61,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) - & u1,v1,ssu,ssv,iopt_flx_over_ocn, & + & u1,v1,ssu,ssv,icplocn2atm, & & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -86,7 +86,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, parameter :: kp = kind_phys integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - integer, intent(in) :: iopt_flx_over_ocn ! option for including ocean current in the computation of flux + integer, intent(in) :: icplocn2atm ! option for including ocean current in the computation of flux integer, dimension(:), intent(in) :: vegtype @@ -128,10 +128,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! locals ! integer i - integer ii - real(kind=kind_phys) :: ssumax, ssvmax real(kind=kind_phys), dimension(im) :: windrel, wind10m - logical :: check_ssu_ssv ! real(kind=kind_phys) :: rat, tv1, thv1, restar, & czilc, tem1, tem2, virtfac @@ -176,17 +173,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - check_ssu_ssv=.false. - if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then - ssumax=0.0 - ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) - enddo - print*, 'in sfc_diff ssumax,ssvmax =',ssumax,ssvmax - print*, 'in sfc_diff iopt_flx_over_ocn =',iopt_flx_over_ocn - print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + if(icplocn2atm == 1) then do i=1,im windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) wind10m(i)= sqrt( (u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2 ) diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 360c2a0c8..1233e17af 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -249,7 +249,7 @@ dimensions = () type = integer intent = in -[iopt_flx_over_ocn] +[icplocn2atm] standard_name = flag_for_air_sea_flux_computation_over_water long_name = air-sea flux option units = flag diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index eb5a2d379..7504b9d49 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -150,7 +150,7 @@ type = real kind = kind_phys intent = in -[iopt_flx_over_ocn] +[icplocn2atm] standard_name = flag_for_air_sea_flux_computation_over_water long_name = air-sea flux option units = flag diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 27e309eca..cde28072a 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -25,7 +25,7 @@ subroutine sfc_ocean_run & ! --- inputs: & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & & tskin, cm, ch, lseaspray, fm, fm10, & - & ssu, ssv, iopt_flx_over_ocn, & + & ssu, ssv, icplocn2atm, & & prsl1, prslki, wet, use_lake_model, wind, &, ! --- inputs & flag_iter, use_med_flux, dqsfc_med, dtsfc_med, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs @@ -40,7 +40,7 @@ subroutine sfc_ocean_run & ! call sfc_ocean ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! -! ssu, ssv, iopt_flx_over_ocn, ! +! ssu, ssv, icplocn2atm, ! ! prsl1, prslki, wet, use_lake_model, wind, flag_iter, ! ! use_med_flux, ! ! outputs: ! @@ -69,7 +69,7 @@ subroutine sfc_ocean_run & ! ps - real, surface pressure im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! ssu,ssv - real, u/v component of surface ocean current (m/s) im ! -! iopt_flx_over_ocn - integer, option for including 1 ! +! icplocn2atm - integer, option for including 1 ! ! ocean current in the computation of flux ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! @@ -110,7 +110,7 @@ subroutine sfc_ocean_run & & zero = 0.0_kind_phys, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - integer, intent(in) :: iopt_flx_over_ocn + integer, intent(in) :: icplocn2atm real (kind=kind_phys), intent(in) :: hvap, cp, rd, & & eps, epsm1, rvrdm1 @@ -144,9 +144,6 @@ subroutine sfc_ocean_run & real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i - real (kind=kind_phys) :: ssumax,ssvmax - !logical,save :: check_ssu_ssv=.true. - logical :: check_ssu_ssv logical :: flag(im) ! @@ -167,18 +164,8 @@ subroutine sfc_ocean_run & ! -- ... initialize CCPP error handling variables errmsg = '' errflg = 0 - check_ssu_ssv=.false. - if(check_ssu_ssv .and. iopt_flx_over_ocn == 1) then - ssumax=0.0 - ssvmax=0.0 - do i=1,im - if(ssu(i) .gt. ssumax) ssumax=ssu(i) - if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) - enddo - print *, 'in sfc_ocean ssumax,ssvmax',ssumax,ssvmax - print *, 'in sfc_ocean iopt_flx_over_ocn',iopt_flx_over_ocn - endif - if(iopt_flx_over_ocn == 1) then + + if(icplocn2atm == 1) then do i=1,im windrel(i) = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) enddo diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f99d74773..dbb9c9131 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -102,7 +102,7 @@ type = real kind = kind_phys intent = in -[iopt_flx_over_ocn] +[icplocn2atm] standard_name = flag_for_air_sea_flux_computation_over_water long_name = air-sea flux option units = flag diff --git a/physics/zzz b/physics/zzz deleted file mode 100755 index e9bd2da01..000000000 --- a/physics/zzz +++ /dev/null @@ -1,12 +0,0 @@ -#!/bin/sh -export src1=/scratch1/NCEPDEV/stmp4/Bin.Li/20231201/ufs-weather-model/FV3/ccpp/physics/physics -cp $src1/satmedmfvdifq.F . -cp $src1/satmedmfvdifq.meta . -cp $src1/sfc_diff.f . -cp $src1/sfc_diff.meta . -cp $src1/sfc_diag.f . -cp $src1/sfc_diag.meta . -cp $src1/sfc_nst.f . -cp $src1/sfc_nst.meta . -cp $src1/sfc_ocean.F . -cp $src1/sfc_ocean.meta . From d65507afb07edc4a50ba246843284552b99e437d Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Thu, 14 Dec 2023 11:16:29 -0500 Subject: [PATCH 45/64] Fix CI 2 --- tools/check_encoding.py | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/tools/check_encoding.py b/tools/check_encoding.py index 1d24d4679..d964ebaab 100755 --- a/tools/check_encoding.py +++ b/tools/check_encoding.py @@ -15,11 +15,7 @@ if suffix in SUFFICES: with open(os.path.join(root, file)) as f: contents = f.read() - try: - contents.decode('ascii') - except UnicodeDecodeError: + if not contents.isascii(): for line in contents.split('\n'): - try: - line.decode('ascii') - except UnicodeDecodeError: + if not line.isascii(): raise Exception('Detected non-ascii characters in file {}, line: "{}"'.format(os.path.join(root, file), line)) From a799bc5d54d6cf3f6503d7214f0cbffc336bc5fb Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Tue, 19 Dec 2023 14:46:51 +0000 Subject: [PATCH 46/64] Revise the following files for the computation of air-sea fluxes. --- physics/satmedmfvdifq.F | 12 +++---- physics/sfc_diag.f | 12 +++---- physics/sfc_diff.f | 77 +++++++++++++++++++++++------------------ physics/sfc_nst.f90 | 24 ++++++------- physics/sfc_ocean.F | 51 +++++++++++++++------------ 5 files changed, 95 insertions(+), 81 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 55667d515..24c12aa8b 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -144,7 +144,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !---------------------------------------------------------------------- !*** !*** local variables - real(kind=kind_phys) spd1_m(im) + real(kind=kind_phys) spd1_m !*** integer i,is,k,n,ndt,km1,kmpbl,kmscu,ntrac1,idtend integer kps,kbx,kmx @@ -2379,13 +2379,13 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo enddo do i = 1,im - if(icplocn2atm == 1) then - spd1_m(i)=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) - dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m(i) - dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m(i) - else + if(icplocn2atm == 0) then dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + else + spd1_m=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) + dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m + dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m endif enddo ! diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 1fa7fa450..183da8b0e 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -31,8 +31,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & implicit none ! integer, intent(in) :: im, lsm, lsm_ruc, iopt_lake, iopt_lake_clm - integer, intent(in) :: icplocn2atm logical, intent(in) :: use_lake2m + integer, intent(in) :: icplocn2atm logical, intent(in) :: thsfc_loc ! Flag for reference pot. temp. logical, intent(in) :: diag_flux ! Flag for flux method in 2-m diagnostics logical, intent(in) :: diag_log ! Flag for 2-m log diagnostics under stable conditions @@ -74,7 +74,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - + !-- testptlat = 35.3_kind_phys testptlon = 273.0_kind_phys @@ -92,12 +92,12 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) - if(icplocn2atm ==1) then - u10m(i) = ssu(i) + f10m(i) * (u1(i)-ssu(i)) - v10m(i) = ssv(i) + f10m(i) * (v1(i)-ssv(i)) - else + if(icplocn2atm ==0) then u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) + else + u10m(i) = ssu(i)+f10m(i) * (u1(i)-ssu(i)) + v10m(i) = ssv(i)+f10m(i) * (v1(i)-ssv(i)) endif have_2m = use_lake_model(i)>0 .and. use_lake2m .and. & & iopt_lake==iopt_lake_clm diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 9c00b7040..1b801aa7a 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -128,9 +128,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! locals ! integer i - real(kind=kind_phys), dimension(im) :: windrel, wind10m + real(kind=kind_phys) :: windrel ! - real(kind=kind_phys) :: rat, tv1, thv1, restar, + real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, & czilc, tem1, tem2, virtfac ! @@ -170,21 +170,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! surface roughness length is converted to m from cm ! -! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - - - if(icplocn2atm == 1) then - do i=1,im - windrel(i)=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) - wind10m(i)= sqrt( (u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2 ) - enddo - else - do i=1,im - wind10m(i)= sqrt( u10m(i)**2 + v10m(i)**2 ) - windrel(i)=wind(i) - enddo - endif - do i=1,im if(flag_iter(i)) then @@ -290,13 +275,24 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tem2 = max(sigmaf(i), 0.1_kp) zvfun(i) = sqrt(tem1 * tem2) ! - call stability + if(icplocn2atm == 0) then + call stability +! --- inputs: + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, +! --- outputs: + & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), + & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + else + windrel=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), - & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel, + & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: - & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), - & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), + & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + endif endif ! Dry points if (icy(i)) then ! Some ice @@ -344,13 +340,23 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ztmax_ice(i) = max(ztmax_ice(i), 1.0e-6) ! - call stability + if(icplocn2atm == 0) then + call stability +! --- inputs: + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, +! --- outputs: + & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), + & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) + else + call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), - & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel, + & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: - & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), - & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) + & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), + & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) + endif endif ! Icy points ! BWG: Everything from here to end of subroutine was after @@ -370,7 +376,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0 = 0.01_kp * z0rl_wat(i) z0max = max(zmin, min(z0,z1(i))) ! ustar_wat(i) = sqrt(grav * z0 / charnock) -! wind10m = sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) + if(icplocn2atm == 0) then + wind10m=sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) + else + wind10m=sqrt((u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2) + endif !** test xubin's new z0 @@ -389,9 +399,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ztmax_wat(i) = max(z0max * exp(-rat), zmin) ! if (sfc_z0_type == 6) then - call znot_t_v6(wind10m(i), ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) + call znot_t_v6(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type == 7) then - call znot_t_v7(wind10m(i), ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) + call znot_t_v7(wind10m, ztmax_wat(i)) ! 10-m wind,m/s, ztmax(m) else if (sfc_z0_type > 0) then write(0,*)'no option for sfc_z0_type=',sfc_z0_type errflg = 1 @@ -401,7 +411,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), +! & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_wat(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), @@ -432,10 +443,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m(i), z0) ! wind, m/s, z0, m + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m z0rl_wat(i) = 100.0_kp * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m(i), z0) ! wind, m/s, z0, m + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m z0rl_wat(i) = 100.0_kp * z0 ! cm else z0rl_wat(i) = 1.0e-4_kp diff --git a/physics/sfc_nst.f90 b/physics/sfc_nst.f90 index 3b5229ba4..1844a1077 100644 --- a/physics/sfc_nst.f90 +++ b/physics/sfc_nst.f90 @@ -240,21 +240,12 @@ subroutine sfc_nst_run & ! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 - real (kind=kind_phys) :: windrel(im) + real (kind=kind_phys) :: windrel ! !====================================================================================================== ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - if(icplocn2atm ==1) then - do i=1,im - windrel(i) = sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) - enddo - else - do i=1,im - windrel(i) = wind(i) - enddo - endif if (nstf_name1 == 0) return ! No NSST model used @@ -326,9 +317,16 @@ subroutine sfc_nst_run & ! --- ... rcp = rho cp ch v - rch(i) = rho_a(i) * cp * ch(i) * windrel(i) - cmm(i) = cm (i) * windrel(i) - chh(i) = rho_a(i) * ch(i) * windrel(i) + if(icplocn2atm ==0) then + rch(i) = rho_a(i) * cp * ch(i) * wind(i) + cmm(i) = cm (i) * wind(i) + chh(i) = rho_a(i) * ch(i) * wind(i) + else + windrel= sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + rch(i) = rho_a(i) * cp * ch(i) * windrel + cmm(i) = cm (i) * windrel + chh(i) = rho_a(i) * ch(i) * windrel + endif !> - Calculate latent and sensible heat flux over open water with tskin. ! at previous time step diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index cde28072a..d8b33f3dc 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -40,7 +40,7 @@ subroutine sfc_ocean_run & ! call sfc_ocean ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! -! ssu, ssv, icplocn2atm, ! +! ssu, ssv, icplocn2atm, ! ! prsl1, prslki, wet, use_lake_model, wind, flag_iter, ! ! use_med_flux, ! ! outputs: ! @@ -69,8 +69,8 @@ subroutine sfc_ocean_run & ! ps - real, surface pressure im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! ssu,ssv - real, u/v component of surface ocean current (m/s) im ! -! icplocn2atm - integer, option for including 1 ! -! ocean current in the computation of flux ! +! icplocn2atm - integrt, =1 if ssu and ssv are used in the 1 ! +! computation of air-sea fluxes ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! @@ -110,19 +110,18 @@ subroutine sfc_ocean_run & & zero = 0.0_kind_phys, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - integer, intent(in) :: icplocn2atm real (kind=kind_phys), intent(in) :: hvap, cp, rd, & & eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind, ssu, & - & ssv + & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind, ssu,ssv ! For sea spray effect logical, intent(in) :: lseaspray ! logical, dimension(:), intent(in) :: flag_iter, wet integer, dimension(:), intent(in) :: use_lake_model + integer, intent(in) :: icplocn2atm ! logical, intent(in) :: use_med_flux @@ -140,8 +139,9 @@ subroutine sfc_ocean_run & ! --- locals: real (kind=kind_phys) :: qss, rch, tem, - & elocp, cpinv, hvapi, windrel(im) + & elocp, cpinv, hvapi real (kind=kind_phys), dimension(im) :: rho, q0 + real (kind=kind_phys), dimension(im) :: windrel integer :: i @@ -165,16 +165,6 @@ subroutine sfc_ocean_run & errmsg = '' errflg = 0 - if(icplocn2atm == 1) then - do i=1,im - windrel(i) = sqrt((u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2) - enddo - else - do i=1,im - windrel(i) = wind(i) - enddo - endif - cpinv = one/cp hvapi = one/hvap elocp = hvap/cp @@ -187,12 +177,21 @@ subroutine sfc_ocean_run & ! rho is density, qss is sat. hum. at surface if ( flag(i) ) then + if (icplocn2atm == 1) then + windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) + endif + if (use_med_flux) then q0(i) = max( q1(i), qmin ) rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) - - tem = ch(i) * windrel(i) - cmm(i) = cm(i) * windrel(i) + + if (icplocn2atm == 0) then + tem = ch(i) * wind(i) + cmm(i) = cm(i) * wind(i) + else + tem = ch(i) * windrel(i) + cmm(i) = cm(i) * windrel(i) + endif chh(i) = rho(i) * tem hflx(i) = dtsfc_med(i) @@ -209,9 +208,15 @@ subroutine sfc_ocean_run & ! --- ... rcp = rho cp ch v - rch = rho(i) * cp * ch(i) * windrel(i) - tem = ch(i) * windrel(i) - cmm(i) = cm(i) * windrel(i) + if (icplocn2atm == 0) then + rch = rho(i) * cp * ch(i) * wind(i) + tem = ch(i) * wind(i) + cmm(i) = cm(i) * wind(i) + else + rch = rho(i) * cp * ch(i) * windrel(i) + tem = ch(i) * windrel(i) + cmm(i) = cm(i) * windrel(i) + endif chh(i) = rho(i) * tem !> - Calcualte sensible and latent heat flux over open water From a5ac3f5289e0c9ad700b65e35483f0592224fa70 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Tue, 26 Dec 2023 15:12:24 +0000 Subject: [PATCH 47/64] Updated sfc_diff.f to add the option to check the surface ocean current. --- physics/sfc_diff.f | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 1b801aa7a..9c143218e 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -126,6 +126,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(out) :: errflg ! ! locals + real(kind=kind_phys) :: ssumax, ssvmax + logical :: check_ssu_ssv ! integer i real(kind=kind_phys) :: windrel @@ -169,6 +171,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm ! + + check_ssu_ssv=.false. + if(check_ssu_ssv) then + ssumax=0.0 + ssvmax=0.0 + do i=1,im + if(ssu(i) .gt. ssumax) ssumax=ssu(i) + if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) + enddo + print*, 'in sfc_diff ssumax,ssvmax im =',ssumax,ssvmax,im + print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + endif do i=1,im if(flag_iter(i)) then From 094860f48799e6e5737cbf1ab147770a34783629 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 27 Dec 2023 12:06:32 +0000 Subject: [PATCH 48/64] update sfc_diff.f --- physics/sfc_diff.f | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 9c143218e..2f392919a 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -180,8 +180,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) if(ssu(i) .gt. ssumax) ssumax=ssu(i) if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) enddo - print*, 'in sfc_diff ssumax,ssvmax im =',ssumax,ssvmax,im - print*, 'in sfc_diff wind(1),u1(1),v1(1) =',wind(1),u1(1),v1(1) + print*, 'sfc_diff ssumax,ssvmax im:',ssumax,ssvmax,im + print*, 'sfc_diff wind(1),u1(1):',wind(1),u1(1) endif do i=1,im From 19cad16dc1cf05626ef2df9fde8f47b0cf3070c1 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Sat, 30 Dec 2023 09:04:51 +0000 Subject: [PATCH 49/64] Update the following files: satmedmfvdif.F satmedmfvdif.meta satmedmfvdifq.F sfc_diag.f sfc_diff.f sfc_nst.f90 sfc_ocean.F --- physics/satmedmfvdif.F | 17 +---------------- physics/satmedmfvdif.meta | 16 ---------------- physics/satmedmfvdifq.F | 2 +- physics/sfc_diag.f | 4 ++-- physics/sfc_diff.f | 38 ++++++++++---------------------------- physics/sfc_nst.f90 | 4 ++-- physics/sfc_ocean.F | 9 ++++----- 7 files changed, 20 insertions(+), 70 deletions(-) diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index cc7ce95b3..79f7bbea1 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -63,7 +63,7 @@ end subroutine satmedmfvdif_init !> @{ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,ssu,ssv,t1,q1,swh,hlw,xmu,garea, & + & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & & prsi,del,prsl,prslk,phii,phil,delt, & @@ -95,7 +95,6 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & - & ssu(:), ssv(:), & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & @@ -218,9 +217,6 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & ! real(kind=kind_phys) h1 integer :: idtend - integer ii - real(kind=kind_phys) :: ssumax, ssvmax - logical :: check_ssu_ssv !! parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) @@ -254,17 +250,6 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 -! - check_ssu_ssv=.false. - if(check_ssu_ssv) then - ssumax=0.0 - ssvmax=0.0 - do ii=1,im - if(ssu(ii) .gt. ssumax) ssumax=ssu(ii) - if(ssv(ii) .gt. ssvmax) ssvmax=ssv(ii) - enddo - print*, 'in satmedmfvdif.F ssumax,ssvmax =',ssumax,ssvmax - endif !> -# Compute preliminary variables from input arguments dt2 = delt diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 522ce543b..3609ed50f 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -211,22 +211,6 @@ type = real kind = kind_phys intent = in -[ssu] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[ssv] - standard_name = ocn_current_merid - long_name = ocn_current_merid - units = m s-1 - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in [t1] standard_name = air_temperature long_name = layer mean air temperature diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 24c12aa8b..90cba0553 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -2382,7 +2382,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & if(icplocn2atm == 0) then dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) - else + else if (icplocn2atm ==1) then spd1_m=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index 183da8b0e..bdc96ade6 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -92,10 +92,10 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & do i = 1, im f10m(i) = fm10(i) / fm(i) - if(icplocn2atm ==0) then + if (icplocn2atm ==0) then u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) - else + else if (icplocn2atm ==1) then u10m(i) = ssu(i)+f10m(i) * (u1(i)-ssu(i)) v10m(i) = ssv(i)+f10m(i) * (v1(i)-ssv(i)) endif diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 2f392919a..0c9bc5275 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -167,11 +167,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) errmsg = '' errflg = 0 + ! initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm ! - +! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type + check_ssu_ssv=.false. if(check_ssu_ssv) then ssumax=0.0 @@ -289,24 +291,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) tem2 = max(sigmaf(i), 0.1_kp) zvfun(i) = sqrt(tem1 * tem2) ! - if(icplocn2atm == 0) then - call stability + call stability ! --- inputs: & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) - else - windrel=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) - call stability -! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, windrel, - & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, -! --- outputs: - & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), - & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) - endif endif ! Dry points if (icy(i)) then ! Some ice @@ -354,23 +345,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ztmax_ice(i) = max(ztmax_ice(i), 1.0e-6) ! - if(icplocn2atm == 0) then - call stability + call stability ! --- inputs: & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) - else - call stability -! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, windrel, - & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, -! --- outputs: - & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), - & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) - endif endif ! Icy points ! BWG: Everything from here to end of subroutine was after @@ -390,10 +371,12 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0 = 0.01_kp * z0rl_wat(i) z0max = max(zmin, min(z0,z1(i))) ! ustar_wat(i) = sqrt(grav * z0 / charnock) - if(icplocn2atm == 0) then + if (icplocn2atm == 0) then wind10m=sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) - else + windrel=wind(i) + else if (icplocn2atm ==1) then wind10m=sqrt((u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2) + windrel=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) endif !** test xubin's new z0 @@ -425,8 +408,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: -! & (z1(i), zvfun(i), gdx, tv1, thv1, windrel(i), - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & (z1(i), zvfun(i), gdx, tv1, thv1, windrel, & z0max, ztmax_wat(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), diff --git a/physics/sfc_nst.f90 b/physics/sfc_nst.f90 index 1844a1077..06d2b061b 100644 --- a/physics/sfc_nst.f90 +++ b/physics/sfc_nst.f90 @@ -317,11 +317,11 @@ subroutine sfc_nst_run & ! --- ... rcp = rho cp ch v - if(icplocn2atm ==0) then + if (icplocn2atm ==0) then rch(i) = rho_a(i) * cp * ch(i) * wind(i) cmm(i) = cm (i) * wind(i) chh(i) = rho_a(i) * ch(i) * wind(i) - else + else if (icplocn2atm ==1) then windrel= sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) rch(i) = rho_a(i) * cp * ch(i) * windrel cmm(i) = cm (i) * windrel diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index d8b33f3dc..0d1ebc2cd 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -177,9 +177,6 @@ subroutine sfc_ocean_run & ! rho is density, qss is sat. hum. at surface if ( flag(i) ) then - if (icplocn2atm == 1) then - windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) - endif if (use_med_flux) then q0(i) = max( q1(i), qmin ) @@ -188,7 +185,8 @@ subroutine sfc_ocean_run & if (icplocn2atm == 0) then tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - else + else if (icplocn2atm ==1) then + windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) tem = ch(i) * windrel(i) cmm(i) = cm(i) * windrel(i) endif @@ -212,7 +210,8 @@ subroutine sfc_ocean_run & rch = rho(i) * cp * ch(i) * wind(i) tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - else + else if (icplocn2atm ==1) then + windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) rch = rho(i) * cp * ch(i) * windrel(i) tem = ch(i) * windrel(i) cmm(i) = cm(i) * windrel(i) From e8eaaf9c1f328bd2ef4f03d1831885b858f305e4 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 3 Jan 2024 10:48:38 +0000 Subject: [PATCH 50/64] Code cleanup --- physics/sfc_diff.f | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 0c9bc5275..1976ab5c2 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -126,8 +126,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) integer, intent(out) :: errflg ! ! locals - real(kind=kind_phys) :: ssumax, ssvmax - logical :: check_ssu_ssv ! integer i real(kind=kind_phys) :: windrel @@ -174,18 +172,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ! write(0,*)'in sfc_diff, sfc_z0_type=',sfc_z0_type - check_ssu_ssv=.false. - if(check_ssu_ssv) then - ssumax=0.0 - ssvmax=0.0 - do i=1,im - if(ssu(i) .gt. ssumax) ssumax=ssu(i) - if(ssv(i) .gt. ssvmax) ssvmax=ssv(i) - enddo - print*, 'sfc_diff ssumax,ssvmax im:',ssumax,ssvmax,im - print*, 'sfc_diff wind(1),u1(1):',wind(1),u1(1) - endif - do i=1,im if(flag_iter(i)) then From f80f52f250d60b311783fe3a317ef14cd93fab22 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Fri, 5 Jan 2024 08:59:25 +0000 Subject: [PATCH 51/64] Change the variable name for zonal ocean current from ssu to usfco. Change the variable name for meridional ocean current from ssv to vsfco. --- physics/satmedmfvdifq.F | 10 +++++----- physics/satmedmfvdifq.meta | 4 ++-- physics/sfc_diag.f | 8 ++++---- physics/sfc_diag.meta | 4 ++-- physics/sfc_diff.f | 9 +++++---- physics/sfc_diff.meta | 4 ++-- physics/sfc_nst.f90 | 8 ++++---- physics/sfc_nst.meta | 4 ++-- physics/sfc_ocean.F | 16 +++++++++------- physics/sfc_ocean.meta | 4 ++-- 10 files changed, 37 insertions(+), 34 deletions(-) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index 90cba0553..9698a140f 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -75,7 +75,7 @@ end subroutine satmedmfvdifq_init !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,ssu,ssv,icplocn2atm, & + & dv,du,tdt,rtg,u1,v1,t1,q1,usfco,vsfco,icplocn2atm, & & swh,hlw,xmu,garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & & tsea,heat,evap,stress,spd1,kpbl, & @@ -110,7 +110,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & tdt(:,:), rtg(:,:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & - & ssu(:), ssv(:), & + & usfco(:), vsfco(:), & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & @@ -2383,9 +2383,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) else if (icplocn2atm ==1) then - spd1_m=sqrt( (u1(i,1)-ssu(i))**2+(v1(i,1)-ssv(i))**2 ) - dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-ssu(i))/spd1_m - dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-ssv(i))/spd1_m + spd1_m=sqrt( (u1(i,1)-usfco(i))**2+(v1(i,1)-vsfco(i))**2 ) + dusfc(i) = -1.*rho_a(i)*stress(i)*(u1(i,1)-usfco(i))/spd1_m + dvsfc(i) = -1.*rho_a(i)*stress(i)*(v1(i,1)-vsfco(i))/spd1_m endif enddo ! diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index c97126457..113843f11 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -217,7 +217,7 @@ type = real kind = kind_phys intent = in -[ssu] +[usfco] standard_name = ocn_current_zonal long_name = ocn_current_zonal units = m s-1 @@ -225,7 +225,7 @@ type = real kind = kind_phys intent = in -[ssv] +[vsfco] standard_name = ocn_current_merid long_name = ocn_current_merid units = m s-1 diff --git a/physics/sfc_diag.f b/physics/sfc_diag.f index bdc96ade6..b0432df6f 100644 --- a/physics/sfc_diag.f +++ b/physics/sfc_diag.f @@ -17,7 +17,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & & lsm,lsm_ruc,grav,cp,eps,epsm1,con_rocp, & & con_karman, & & shflx,cdq,wind, & - & ssu,ssv,icplocn2atm, & + & usfco,vsfco,icplocn2atm, & & zf,ps,u1,v1,t1,q1,prslki,evap,fm,fh,fm10,fh2, & & ust,tskin,qsurf,thsfc_loc,diag_flux,diag_log, & & use_lake_model,iopt_lake,iopt_lake_clm, & @@ -40,7 +40,7 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & real(kind=kind_phys), intent(in) :: con_karman real(kind=kind_phys), dimension(:), intent( in) :: & & zf, ps, u1, v1, t1, q1, ust, tskin, & - & ssu, ssv, & + & usfco, vsfco, & & qsurf, prslki, evap, fm, fh, fm10, fh2, & & shflx, cdq, wind, xlat_d, xlon_d real(kind=kind_phys), dimension(:), intent(out) :: & @@ -96,8 +96,8 @@ subroutine sfc_diag_run (im,xlat_d,xlon_d, & u10m(i) = f10m(i) * u1(i) v10m(i) = f10m(i) * v1(i) else if (icplocn2atm ==1) then - u10m(i) = ssu(i)+f10m(i) * (u1(i)-ssu(i)) - v10m(i) = ssv(i)+f10m(i) * (v1(i)-ssv(i)) + u10m(i) = usfco(i)+f10m(i) * (u1(i)-usfco(i)) + v10m(i) = vsfco(i)+f10m(i) * (v1(i)-vsfco(i)) endif have_2m = use_lake_model(i)>0 .and. use_lake2m .and. & & iopt_lake==iopt_lake_clm diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index da300d053..44f3b5c6a 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -123,7 +123,7 @@ type = real kind = kind_phys intent = in -[ssu] +[usfco] standard_name = ocn_current_zonal long_name = ocn_current_zonal units = m s-1 @@ -131,7 +131,7 @@ type = real kind = kind_phys intent = in -[ssv] +[vsfco] standard_name = ocn_current_merid long_name = ocn_current_merid units = m s-1 diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 1976ab5c2..96f96faeb 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -61,7 +61,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) & flag_iter,redrag, & !intent(in) & u10m,v10m,sfc_z0_type, & !hafs,z0 type !intent(in) - & u1,v1,ssu,ssv,icplocn2atm, & + & u1,v1,usfco,vsfco,icplocn2atm, & & wet,dry,icy, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) @@ -97,7 +97,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) logical, intent(in) :: thsfc_loc ! Flag for reference pressure in theta calculation real(kind=kind_phys), dimension(:), intent(in) :: u10m,v10m - real(kind=kind_phys), dimension(:), intent(in) :: u1,v1,ssu,ssv + real(kind=kind_phys), dimension(:), intent(in) :: u1,v1 + real(kind=kind_phys), dimension(:), intent(in) :: usfco,vsfco real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav real(kind=kind_phys), dimension(:), intent(in) :: & & ps,t1,q1,z1,garea,prsl1,prslki,prsik1,prslk1, & @@ -361,8 +362,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) wind10m=sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) windrel=wind(i) else if (icplocn2atm ==1) then - wind10m=sqrt((u10m(i)-ssu(i))**2 + (v10m(i)-ssv(i))**2) - windrel=sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + wind10m=sqrt((u10m(i)-usfco(i))**2 + (v10m(i)-vsfco(i))**2) + windrel=sqrt( (u1(i)-usfco(i))**2 + (v1(i)-vsfco(i))**2 ) endif !** test xubin's new z0 diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 1233e17af..3a141712b 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -226,7 +226,7 @@ type = real kind = kind_phys intent = in -[ssu] +[usfco] standard_name = ocn_current_zonal long_name = ocn_current_zonal units = m s-1 @@ -234,7 +234,7 @@ type = real kind = kind_phys intent = in -[ssv] +[vsfco] standard_name = ocn_current_merid long_name = ocn_current_merid units = m s-1 diff --git a/physics/sfc_nst.f90 b/physics/sfc_nst.f90 index 06d2b061b..1dd9d6117 100644 --- a/physics/sfc_nst.f90 +++ b/physics/sfc_nst.f90 @@ -26,7 +26,7 @@ module sfc_nst !> \section NSST_general_algorithm GFS Near-Surface Sea Temperature Scheme General Algorithm subroutine sfc_nst_run & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: - pi, tgice, sbc, ps, u1, v1, ssu, ssv, icplocn2atm, t1, & + pi, tgice, sbc, ps, u1, v1, usfco, vsfco, icplocn2atm, t1, & q1, tref, cm, ch, lseaspray, fm, fm10, & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & sinlat, stress, & @@ -84,7 +84,7 @@ subroutine sfc_nst_run & ! im - integer, horiz dimension 1 ! ! ps - real, surface pressure (pa) im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! - ! ssu, ssv - real, u/v component of surface current (m/s) im ! + ! usfco, vsfco - real, u/v component of surface current (m/s) im ! ! icplocn2atm - integer, option to include ocean surface 1 ! ! current in the computation of flux ! ! t1 - real, surface layer mean temperature ( k ) im ! @@ -175,7 +175,7 @@ subroutine sfc_nst_run & real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - ssu, ssv, t1, q1, tref, cm, ch, fm, fm10, & + usfco, vsfco, t1, q1, tref, cm, ch, fm, fm10, & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind real (kind=kind_phys), intent(in) :: timestep @@ -322,7 +322,7 @@ subroutine sfc_nst_run & cmm(i) = cm (i) * wind(i) chh(i) = rho_a(i) * ch(i) * wind(i) else if (icplocn2atm ==1) then - windrel= sqrt( (u1(i)-ssu(i))**2 + (v1(i)-ssv(i))**2 ) + windrel= sqrt( (u1(i)-usfco(i))**2 + (v1(i)-vsfco(i))**2 ) rch(i) = rho_a(i) * cp * ch(i) * windrel cmm(i) = cm (i) * windrel chh(i) = rho_a(i) * ch(i) * windrel diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 7504b9d49..a9082515e 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -134,7 +134,7 @@ type = real kind = kind_phys intent = in -[ssu] +[usfco] standard_name = ocn_current_zonal long_name = ocn_current_zonal units = m s-1 @@ -142,7 +142,7 @@ type = real kind = kind_phys intent = in -[ssv] +[vsfco] standard_name = ocn_current_merid long_name = ocn_current_merid units = m s-1 diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 0d1ebc2cd..505476510 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -25,7 +25,7 @@ subroutine sfc_ocean_run & ! --- inputs: & ( im, hvap, cp, rd, eps, epsm1, rvrdm1, ps, u1, v1, t1, q1, & & tskin, cm, ch, lseaspray, fm, fm10, & - & ssu, ssv, icplocn2atm, & + & usfco, vsfco, icplocn2atm, & & prsl1, prslki, wet, use_lake_model, wind, &, ! --- inputs & flag_iter, use_med_flux, dqsfc_med, dtsfc_med, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs @@ -40,7 +40,7 @@ subroutine sfc_ocean_run & ! call sfc_ocean ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! -! ssu, ssv, icplocn2atm, ! +! usfco, vsfco, icplocn2atm, ! ! prsl1, prslki, wet, use_lake_model, wind, flag_iter, ! ! use_med_flux, ! ! outputs: ! @@ -68,8 +68,9 @@ subroutine sfc_ocean_run & ! im - integer, horizontal dimension 1 ! ! ps - real, surface pressure im ! ! u1, v1 - real, u/v component of surface layer wind (m/s) im ! -! ssu,ssv - real, u/v component of surface ocean current (m/s) im ! -! icplocn2atm - integrt, =1 if ssu and ssv are used in the 1 ! +! usfco - real, u component of surface ocean current (m/s) im ! +! vsfco - real, v component of surface ocean current (m/s) im ! +! icplocn2atm - integer, =1 if usfco and vsfco are used in the 1 ! ! computation of air-sea fluxes ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! @@ -114,7 +115,8 @@ subroutine sfc_ocean_run & & eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind, ssu,ssv + & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind, & + & usfco, vsfco ! For sea spray effect logical, intent(in) :: lseaspray @@ -186,7 +188,7 @@ subroutine sfc_ocean_run & tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) else if (icplocn2atm ==1) then - windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) + windrel(i)=sqrt( (u1(i)-usfco(i))**2+(v1(i)-vsfco(i))**2 ) tem = ch(i) * windrel(i) cmm(i) = cm(i) * windrel(i) endif @@ -211,7 +213,7 @@ subroutine sfc_ocean_run & tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) else if (icplocn2atm ==1) then - windrel(i)=sqrt( (u1(i)-ssu(i))**2+(v1(i)-ssv(i))**2 ) + windrel(i)=sqrt( (u1(i)-usfco(i))**2+(v1(i)-vsfco(i))**2 ) rch = rho(i) * cp * ch(i) * windrel(i) tem = ch(i) * windrel(i) cmm(i) = cm(i) * windrel(i) diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index dbb9c9131..ac063ab5d 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -86,7 +86,7 @@ type = real kind = kind_phys intent = in -[ssu] +[usfco] standard_name = ocn_current_zonal long_name = ocn_current_zonal units = m s-1 @@ -94,7 +94,7 @@ type = real kind = kind_phys intent = in -[ssv] +[vsfco] standard_name = ocn_current_merid long_name = ocn_current_merid units = m s-1 From fa1078f56b72f9a3f38c5332cefc372b69ed55c2 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Sat, 6 Jan 2024 11:54:13 +0000 Subject: [PATCH 52/64] Update sfc_diff.f. --- physics/sfc_diff.f | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index 96f96faeb..5a9b1e54f 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -359,11 +359,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(zmin, min(z0,z1(i))) ! ustar_wat(i) = sqrt(grav * z0 / charnock) if (icplocn2atm == 0) then - wind10m=sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i)) + wind10m=sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) windrel=wind(i) else if (icplocn2atm ==1) then - wind10m=sqrt((u10m(i)-usfco(i))**2 + (v10m(i)-vsfco(i))**2) - windrel=sqrt( (u1(i)-usfco(i))**2 + (v1(i)-vsfco(i))**2 ) + wind10m=sqrt((u10m(i)-usfco(i))**2+(v10m(i)-vsfco(i))**2) + windrel=sqrt((u1(i)-usfco(i))**2+(v1(i)-vsfco(i))**2) endif !** test xubin's new z0 From fe77e06ab907accb3b860857d050f990ba88662d Mon Sep 17 00:00:00 2001 From: Ufuk Turuncoglu Date: Mon, 8 Jan 2024 11:54:41 -0600 Subject: [PATCH 53/64] move sfc_land to new location --- physics/{ => SFC_Models/Land}/sfc_land.F90 | 0 physics/{ => SFC_Models/Land}/sfc_land.meta | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename physics/{ => SFC_Models/Land}/sfc_land.F90 (100%) rename physics/{ => SFC_Models/Land}/sfc_land.meta (100%) diff --git a/physics/sfc_land.F90 b/physics/SFC_Models/Land/sfc_land.F90 similarity index 100% rename from physics/sfc_land.F90 rename to physics/SFC_Models/Land/sfc_land.F90 diff --git a/physics/sfc_land.meta b/physics/SFC_Models/Land/sfc_land.meta similarity index 100% rename from physics/sfc_land.meta rename to physics/SFC_Models/Land/sfc_land.meta From 09b02350a7526f1eddc0885f8bcb26e9cac5c72d Mon Sep 17 00:00:00 2001 From: Ufuk Turuncoglu Date: Mon, 8 Jan 2024 11:55:57 -0600 Subject: [PATCH 54/64] fix meta file --- physics/SFC_Models/Land/sfc_land.meta | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/physics/SFC_Models/Land/sfc_land.meta b/physics/SFC_Models/Land/sfc_land.meta index 493d2a70b..6a4bd8fbe 100644 --- a/physics/SFC_Models/Land/sfc_land.meta +++ b/physics/SFC_Models/Land/sfc_land.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = sfc_land type = scheme - dependencies = machine.F + dependencies = ../../hooks/machine.F ######################################################################## [ccpp-arg-table] From ea70fbdaa81c2ad4b8f1b7a7b7bd31fa9115fc52 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Wed, 17 Jan 2024 15:42:07 +0000 Subject: [PATCH 55/64] Make changes for consistent style. --- physics/SFC_Layer/UFS/sfc_diff.f | 17 ++++++++--------- physics/SFC_Layer/UFS/sfc_nst.f90 | 2 +- physics/SFC_Models/Ocean/UFS/sfc_ocean.F | 1 - 3 files changed, 9 insertions(+), 11 deletions(-) diff --git a/physics/SFC_Layer/UFS/sfc_diff.f b/physics/SFC_Layer/UFS/sfc_diff.f index f4a102c91..eb5bd7b5c 100644 --- a/physics/SFC_Layer/UFS/sfc_diff.f +++ b/physics/SFC_Layer/UFS/sfc_diff.f @@ -168,7 +168,6 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) errmsg = '' errflg = 0 - ! initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! surface roughness length is converted to m from cm @@ -282,11 +281,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), - & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: - & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), - & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) + & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), + & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) endif ! Dry points if (icy(i)) then ! Some ice @@ -336,11 +335,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), - & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: - & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), - & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) + & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), + & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) endif ! Icy points ! BWG: Everything from here to end of subroutine was after diff --git a/physics/SFC_Layer/UFS/sfc_nst.f90 b/physics/SFC_Layer/UFS/sfc_nst.f90 index 1dd9d6117..9c3804211 100644 --- a/physics/SFC_Layer/UFS/sfc_nst.f90 +++ b/physics/SFC_Layer/UFS/sfc_nst.f90 @@ -27,7 +27,7 @@ module sfc_nst subroutine sfc_nst_run & ( im, hvap, cp, hfus, jcal, eps, epsm1, rvrdm1, rd, rhw0, & ! --- inputs: pi, tgice, sbc, ps, u1, v1, usfco, vsfco, icplocn2atm, t1, & - q1, tref, cm, ch, lseaspray, fm, fm10, & + q1, tref, cm, ch, lseaspray, fm, fm10, & prsl1, prslki, prsik1, prslk1, wet, use_lake_model, xlon, & sinlat, stress, & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & diff --git a/physics/SFC_Models/Ocean/UFS/sfc_ocean.F b/physics/SFC_Models/Ocean/UFS/sfc_ocean.F index 505476510..88d23a7aa 100644 --- a/physics/SFC_Models/Ocean/UFS/sfc_ocean.F +++ b/physics/SFC_Models/Ocean/UFS/sfc_ocean.F @@ -179,7 +179,6 @@ subroutine sfc_ocean_run & ! rho is density, qss is sat. hum. at surface if ( flag(i) ) then - if (use_med_flux) then q0(i) = max( q1(i), qmin ) rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) From c9460205f6047047025536653e05675749b9d074 Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Wed, 17 Jan 2024 15:54:26 +0000 Subject: [PATCH 56/64] fix NSSL MP init issue when initialized from other microphysics schemes --- physics/MP/NSSL/mp_nssl.F90 | 42 ++++++++++++++-- physics/MP/NSSL/mp_nssl.meta | 95 ++++++++++++++++++++++++++++++++++++ 2 files changed, 134 insertions(+), 3 deletions(-) diff --git a/physics/MP/NSSL/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 index e79376709..ad1d41090 100644 --- a/physics/MP/NSSL/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -15,6 +15,7 @@ module mp_nssl private logical :: is_initialized = .False. + logical :: missing_vars_global = .False. real :: nssl_qccn contains @@ -26,7 +27,9 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpirank, mpiroot, & + mpirank, mpiroot,mpicomm, & + qc, qr, qi, qs, qh, & + ccw, crw, cci, csw, chw, vh, & con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps, & imp_physics, imp_physics_nssl, & @@ -36,6 +39,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & use module_mp_nssl_2mom, only: nssl_2mom_init, nssl_2mom_init_const +#ifdef MPI + use mpi +#endif implicit none @@ -50,16 +56,32 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + integer, intent(in) :: mpicomm integer, intent(in) :: imp_physics integer, intent(in) :: imp_physics_nssl real(kind_phys), intent(in) :: nssl_cccn, nssl_alphah, nssl_alphahl real(kind_phys), intent(in) :: nssl_alphar, nssl_ehw0, nssl_ehlw0 logical, intent(in) :: nssl_ccn_on, nssl_hail_on, nssl_invertccn, nssl_3moment + real(kind_phys), intent(inout) :: qc (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qr (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qi (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qs (:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: qh (:,:) !(1:ncol,1:nlev) graupel + real(kind_phys), intent(inout) :: ccw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: crw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: cci(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: csw(:,:) !(1:ncol,1:nlev) + real(kind_phys), intent(inout) :: chw(:,:) !(1:ncol,1:nlev) graupel number + real(kind_phys), intent(inout) :: vh (:,:) !(1:ncol,1:nlev) graupel volume + ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) integer :: ihailv,ipc + real, parameter :: qmin = 1.e-12 + integer :: ierr + logical :: missing_vars = .False. ! Initialize the CCPP error handling variables @@ -143,6 +165,19 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! For restart runs, the init is done here if (restart) then + + ! For restart, check if the IC is from a different scheme that does not have all the needed variables + missing_vars = .False. + IF ( Any( qc > qmin .and. ccw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qi > qmin .and. cci == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qs > qmin .and. csw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qr > qmin .and. crw == 0.0 ) ) missing_vars = .true. + IF ( .not. missing_vars .and. Any( qh > qmin .and. (chw == 0.0 .or. vh == 0.0) ) ) missing_vars = .true. + +#ifdef MPI + call MPI_Allreduce(missing_vars, missing_vars_global, 1, MPI_LOGICAL, MPI_LOR, mpicomm, ierr) +#endif + is_initialized = .true. return end if @@ -319,6 +354,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real :: cwmas real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array + errflg = 0 @@ -529,8 +565,8 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & dtptmp = dtp ntmul = 1 ENDIF - - IF ( first_time_step .and. .not. restart ) THEN + + IF ( first_time_step .and. ( .not. restart .or. missing_vars_global ) ) THEN itimestep = 0 ! gets incremented to 1 in call loop IF ( nssl_ccn_on ) THEN IF ( invertccn ) THEN diff --git a/physics/MP/NSSL/mp_nssl.meta b/physics/MP/NSSL/mp_nssl.meta index 1f2023ea9..8449f26cf 100644 --- a/physics/MP/NSSL/mp_nssl.meta +++ b/physics/MP/NSSL/mp_nssl.meta @@ -63,6 +63,101 @@ dimensions = () type = integer intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[qc] + standard_name = cloud_liquid_water_mixing_ratio + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension ,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qr] + standard_name = rain_mixing_ratio + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qi] + standard_name = cloud_ice_mixing_ratio + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qs] + standard_name = snow_mixing_ratio + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qh] + standard_name = graupel_mixing_ratio + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[ccw] + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[crw] + standard_name = mass_number_concentration_of_rain_water_in_air + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[cci] + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[csw] + standard_name = mass_number_concentration_of_snow_in_air + long_name = snow number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chw] + standard_name = mass_number_concentration_of_graupel_in_air + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vh] + standard_name = graupel_volume + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout [con_g] standard_name = gravitational_acceleration long_name = gravitational acceleration From 97e3b1ce4e9721ae6cc361733842de53a061d7ed Mon Sep 17 00:00:00 2001 From: Qingfu Liu Date: Thu, 18 Jan 2024 12:24:03 -0500 Subject: [PATCH 57/64] update surface physics z0 from waves --- physics/SFC_Layer/UFS/sfc_diff.f | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/physics/SFC_Layer/UFS/sfc_diff.f b/physics/SFC_Layer/UFS/sfc_diff.f index e1bf3c756..5dd6525f9 100644 --- a/physics/SFC_Layer/UFS/sfc_diff.f +++ b/physics/SFC_Layer/UFS/sfc_diff.f @@ -437,6 +437,18 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0rl_wat(i) = 1.0e-4_kp endif + elseif (z0rl_wav(i) <= 1.0e-7_kp .or. + & z0rl_wav(i) > 1.0_kp) then +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + + if (redrag) then + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) + else + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) + endif + endif endif ! end of if(open ocean) From 02b3440378e5bb04ddc4ba50b44f2532eb7cab08 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Fri, 19 Jan 2024 18:24:37 +0000 Subject: [PATCH 58/64] "Supplementary physics updates for RRFS code freeze" --- physics/CONV/Grell_Freitas/cu_gf_deep.F90 | 5 +- physics/CONV/Grell_Freitas/cu_gf_driver.F90 | 8 +- physics/CONV/Grell_Freitas/cu_gf_driver.meta | 7 + physics/PBL/MYNN_EDMF/module_bl_mynn.F90 | 146 ++++++++---------- .../SFC_Models/Land/RUC/module_sf_ruclsm.F90 | 6 +- physics/smoke_dust/dep_dry_mod_emerson.F90 | 58 ++++--- physics/smoke_dust/dust_fengsha_mod.F90 | 11 +- physics/smoke_dust/module_add_emiss_burn.F90 | 75 +++++---- physics/smoke_dust/module_plumerise.F90 | 61 +++++--- physics/smoke_dust/module_smoke_plumerise.F90 | 40 ++--- physics/smoke_dust/module_wetdep_ls.F90 | 13 +- physics/smoke_dust/plume_data_mod.F90 | 51 ------ physics/smoke_dust/rrfs_smoke_config.F90 | 3 +- physics/smoke_dust/rrfs_smoke_postpbl.meta | 3 +- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 145 ++++++++++------- physics/smoke_dust/rrfs_smoke_wrapper.meta | 85 +++++++++- 16 files changed, 424 insertions(+), 293 deletions(-) delete mode 100755 physics/smoke_dust/plume_data_mod.F90 diff --git a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 index a1bca36c9..8a2c73600 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -142,13 +142,13 @@ subroutine cu_gf_deep_run( & !! betwee -1 and +1 ,do_capsuppress,cap_suppress_j & ! ,k22 & ! - ,jmin,tropics) ! + ,jmin,kdt,tropics) ! implicit none integer & ,intent (in ) :: & - nranflag,itf,ktf,its,ite, kts,kte,ipr,imid + nranflag,itf,ktf,its,ite, kts,kte,ipr,imid,kdt integer, intent (in ) :: & ichoice,nchem real(kind=kind_phys), dimension (its:ite,4) & @@ -591,6 +591,7 @@ subroutine cu_gf_deep_run( & sig(i)=(1.-frh)**2 !frh_out(i) = frh if(forcing(i,7).eq.0.)sig(i)=1. + if(kdt.le.(3600./dtime))sig(i)=1. frh_out(i) = frh*sig(i) enddo !$acc end kernels diff --git a/physics/CONV/Grell_Freitas/cu_gf_driver.F90 b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 index 92f8760b0..54a23ca74 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_driver.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.F90 @@ -68,7 +68,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& dfi_radar_max_intervals,ldiag3d,qci_conv,do_cap_suppress, & maxupmf,maxMF,do_mynnedmf,ichoice_in,ichoicem_in,ichoice_s_in, & spp_cu_deep,spp_wts_cu_deep,nchem,chem3d,fscav,wetdpc_deep, & - do_smoke_transport,errmsg,errflg) + do_smoke_transport,kdt,errmsg,errflg) !------------------------------------------------------------- implicit none integer, parameter :: maxiens=1 @@ -95,7 +95,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& integer :: ishallow_g3 ! depend on imfshalcnv !------------------------------------------------------------- integer :: its,ite, jts,jte, kts,kte - integer, intent(in ) :: im,km,ntracer, nchem + integer, intent(in ) :: im,km,ntracer,nchem,kdt integer, intent(in ) :: ichoice_in,ichoicem_in,ichoice_s_in logical, intent(in ) :: flag_init, flag_restart, do_mynnedmf logical, intent(in ) :: flag_for_scnv_generic_tend,flag_for_dcnv_generic_tend @@ -766,7 +766,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22m & - ,jminm,tropics) + ,jminm,kdt,tropics) !$acc kernels do i=its,itf do k=kts,ktf @@ -853,7 +853,7 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& ! betwee -1 and +1 ,do_cap_suppress_here,cap_suppress_j & ,k22 & - ,jmin,tropics) + ,jmin,kdt,tropics) jpr=0 ipr=0 !$acc kernels diff --git a/physics/CONV/Grell_Freitas/cu_gf_driver.meta b/physics/CONV/Grell_Freitas/cu_gf_driver.meta index fe9b4c375..d0b661fd8 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_driver.meta +++ b/physics/CONV/Grell_Freitas/cu_gf_driver.meta @@ -651,6 +651,13 @@ type = real kind = kind_phys intent = inout +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 index 6840f80bf..cc7a47ce6 100644 --- a/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 +++ b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 @@ -2001,9 +2001,9 @@ SUBROUTINE mym_length ( & uonset= 15. wt_u = (1.0 - min(max(ugrid - uonset, 0.0)/30.0, 0.5)) cns = 2.7 !was 3.5 - alp1 = 0.22 + alp1 = 0.23 alp2 = 0.3 - alp3 = 2.0 * wt_u !taper off bouyancy enhancement in shear-driven pbls + alp3 = 2.5 * wt_u !taper off bouyancy enhancement in shear-driven pbls alp4 = 5.0 alp5 = 0.3 alp6 = 50. @@ -2059,12 +2059,12 @@ SUBROUTINE mym_length ( & ! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = max( sqrt( gtr*dtv(k) ), 0.001) + bv = max( sqrt( gtr*dtv(k) ), 0.0001) elb = MAX(alp2*qkw(k), & & alp6*edmf_a1(k-1)*edmf_w1(k-1)) / bv & & *( 1.0 + alp3*SQRT( vsc/(bv*elt) ) ) elb = MIN(elb, zwk) - elf = 0.80 * qkw(k)/bv + elf = 1.0 * qkw(k)/bv elBLavg(k) = MAX(elBLavg(k), alp6*edmf_a1(k-1)*edmf_w1(k-1)/bv) ELSE elb = 1.0e10 @@ -2084,8 +2084,10 @@ SUBROUTINE mym_length ( & !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) !el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - !try squared-blending - el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + !try squared-blending - but take out elb (makes it underdiffusive) + !el(k) = SQRT( els**2/(1. + (els**2/elt**2) +(els**2/elb**2))) + el(k) = sqrt( els**2/(1. + (els**2/elt**2))) + el(k) = min(el(k), elb) el(k) = MIN (el(k), elf) el(k) = el(k)*(1.-wt) + alp5*elBLavg(k)*wt @@ -3633,13 +3635,13 @@ SUBROUTINE mym_condensation (kts,kte, & real(kind_phys):: qsl,esat,qsat,dqsl,cld0,q1k,qlk,eq1,qll, & &q2p,pt,rac,qt,t,xl,rsl,cpm,Fng,qww,alpha,beta,bb, & - &ls,wt,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & + &ls,wt,wt2,qpct,cld_factor,fac_damp,liq_frac,ql_ice,ql_water, & &qmq,qsat_tk,q1_rh,rh_hack,dzm1,zsl,maxqc real(kind_phys), parameter :: qpct_sfc=0.025 real(kind_phys), parameter :: qpct_pbl=0.030 real(kind_phys), parameter :: qpct_trp=0.040 real(kind_phys), parameter :: rhcrit =0.83 !for cloudpdf = 2 - real(kind_phys), parameter :: rhmax =1.01 !for cloudpdf = 2 + real(kind_phys), parameter :: rhmax =1.02 !for cloudpdf = 2 integer :: i,j,k real(kind_phys):: erf @@ -3864,25 +3866,18 @@ SUBROUTINE mym_condensation (kts,kte, & !Add condition for falling/settling into low-RH layers, so at least !some cloud fraction is applied for all qc, qs, and qi. rh_hack= rh(k) + wt2 = min(max( zagl - pblh2, 0.0 )/300., 1.0) !ensure adequate RH & q1 when qi is at least 1e-9 (above the PBLH) - if (qi(k)>1.e-9 .and. zagl .gt. pblh2) then - rh_hack =min(rhmax, rhcrit + 0.07*(9.0 + log10(qi(k)))) + if ((qi(k)+qs(k))>1.e-9 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.045*(9.0 + log10(qi(k)+qs(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) q1(k) =max(q1_rh, q1(k) ) endif - !ensure adequate RH & q1 when qc is at least 1e-6 - if (qc(k)>1.e-6) then - rh_hack =min(rhmax, rhcrit + 0.09*(6.0 + log10(qc(k)))) - rh(k) =max(rh(k), rh_hack) - !add rh-based q1 - q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) - q1(k) =max(q1_rh, q1(k) ) - endif - !ensure adequate RH & q1 when qs is at least 1e-8 (above the PBLH) - if (qs(k)>1.e-8 .and. zagl .gt. pblh2) then - rh_hack =min(rhmax, rhcrit + 0.07*(8.0 + log10(qs(k)))) + !ensure adequate rh & q1 when qc is at least 1e-6 (above the PBLH) + if (qc(k)>1.e-6 .and. (zagl .gt. pblh2)) then + rh_hack =min(rhmax, rhcrit + wt2*0.08*(6.0 + log10(qc(k)))) rh(k) =max(rh(k), rh_hack) !add rh-based q1 q1_rh =-3. + 3.*(rh(k)-rhcrit)/(1.-rhcrit) @@ -3994,7 +3989,7 @@ SUBROUTINE mym_condensation (kts,kte, & fac_damp = min(zagl * 0.0025, 1.0) !cld_factor = 1.0 + fac_damp*MAX(0.0, ( RH(k) - 0.75 ) / 0.26 )**1.9 !HRRRv4 !cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.25 )**2, 0.3) - cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.35) + cld_factor = 1.0 + fac_damp*min((max(0.0, ( RH(k) - 0.92 )) / 0.145)**2, 0.37) cldfra_bl1D(K) = min( 1., cld_factor*cldfra_bl1D(K) ) enddo @@ -4181,38 +4176,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff + & -! sub_u(k)*delt + det_u(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + b(k)=1.+dtz(k)*(kmdz(k+1)+rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff - & - & dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=u(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*uoce*ust**2/wspd - & -! !!!d(k)=u(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*uoce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awu(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff + sub_u(k)*delt + det_u(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff + & - & sub_u(k)*delt + det_u(k)*delt - ENDDO + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*uoce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awu(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awu(k+1)*onoff & + & + sub_u(k)*delt + det_u(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+ dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= - dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=u(k) + dtz(k)*rhoinv(k)*(s_awu(k)-s_awu(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awu(k)-sd_awu(k+1))*onoff & + & + sub_u(k)*delt + det_u(k)*delt + enddo !! no flux at the top ! a(kte)=-1. @@ -4247,37 +4237,33 @@ SUBROUTINE mynn_tendencies(kts,kte,i, & k=kts -!original approach (drag in b-vector): -! a(1)=0. -! b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff -! c(1)= - dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff -! d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff + & -! sub_v(k)*delt + det_v(k)*delt - !rho-weighted (drag in b-vector): a(k)= -dtz(k)*kmdz(k)*rhoinv(k) - b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & - & - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + & - & sub_v(k)*delt + det_v(k)*delt - -!rho-weighted with drag term moved out of b-array -! a(k)= -dtz(k)*kmdz(k)*rhoinv(k) -! b(k)=1.+dtz(k)*(kmdz(k+1))*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff -! d(k)=v(k)*(1.-ust**2/wspd*dtz(k)*rhosfc/rho(k)) + dtz(k)*voce*ust**2/wspd - & -! !!!d(k)=v(k)*(1.-ust**2/wspd*dtz(k)) + dtz(k)*voce*ust**2/wspd - & -! & dtz(k)*rhoinv(k)*s_awv(k+1)*onoff - dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff + sub_v(k)*delt + det_v(k)*delt - - DO k=kts+1,kte-1 - a(k)= -dtz(k)*kmdz(k)*rhoinv(k) + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff - b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) + & - & 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff - c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff - d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff + dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff + & - & sub_v(k)*delt + det_v(k)*delt - ENDDO + b(k)=1.+dtz(k)*(kmdz(k+1) + rhosfc*ust**2/wspd)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*voce*ust**2/wspd & + & - dtz(k)*rhoinv(k)*s_awv(k+1)*onoff & + & + dtz(k)*rhoinv(k)*sd_awv(k+1)*onoff & + & + sub_v(k)*delt + det_v(k)*delt + + do k=kts+1,kte-1 + a(k)= -dtz(k)*kmdz(k)*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*s_aw(k)*onoff & + & + 0.5*dtz(k)*rhoinv(k)*sd_aw(k)*onoff + b(k)=1.+dtz(k)*(kmdz(k)+kmdz(k+1))*rhoinv(k) & + & + 0.5*dtz(k)*rhoinv(k)*(s_aw(k)-s_aw(k+1))*onoff & + & + 0.5*dtz(k)*rhoinv(k)*(sd_aw(k)-sd_aw(k+1))*onoff + c(k)= -dtz(k)*kmdz(k+1)*rhoinv(k) & + & - 0.5*dtz(k)*rhoinv(k)*s_aw(k+1)*onoff & + & - 0.5*dtz(k)*rhoinv(k)*sd_aw(k+1)*onoff + d(k)=v(k) + dtz(k)*rhoinv(k)*(s_awv(k)-s_awv(k+1))*onoff & + & - dtz(k)*rhoinv(k)*(sd_awv(k)-sd_awv(k+1))*onoff & + & + sub_v(k)*delt + det_v(k)*delt + enddo !! no flux at the top ! a(kte)=-1. diff --git a/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 index b15592052..2d01f96c9 100644 --- a/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 +++ b/physics/SFC_Models/Land/RUC/module_sf_ruclsm.F90 @@ -1687,7 +1687,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia endif if(newsn > zero ) then - SNOWFRACnewsn=MIN(one,SNHEI/SNHEI_CRIT_newsn) + SNOWFRACnewsn=MIN(one,snowfallac*1.e-3_kind_phys/SNHEI_CRIT_newsn) endif !-- due to steep slopes and blown snow, limit snow fraction in the @@ -1700,7 +1700,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia if(snowfrac < 0.75_kind_phys) snow_mosaic = one KEEP_SNOW_ALBEDO = zero - IF (NEWSN > zero .and. snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN + IF (snowfracnewsn > 0.99_kind_phys .and. rhosnfall < 450._kind_phys) THEN ! new snow KEEP_SNOW_ALBEDO = one ! turn off separate treatment of snow covered and snow-free portions of the grid cell @@ -1735,7 +1735,7 @@ SUBROUTINE SFCTMP (debug_print, delt,ktau,conflx,i,j, & !--- input varia ! hwlps with these biases.. if( snow_mosaic == one) then ALBsn=alb_snow - if(newsn > zero .and. KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then + if(KEEP_SNOW_ALBEDO > 0.9_kind_phys .and. albsn < 0.4_kind_phys) then !-- Albedo correction with fresh snow and deep snow pack !-- will reduce warm bias in western Canada !-- and US West coast, where max snow albedo is low (0.3-0.5). diff --git a/physics/smoke_dust/dep_dry_mod_emerson.F90 b/physics/smoke_dust/dep_dry_mod_emerson.F90 index 76fdc2411..771801c44 100755 --- a/physics/smoke_dust/dep_dry_mod_emerson.F90 +++ b/physics/smoke_dust/dep_dry_mod_emerson.F90 @@ -9,7 +9,7 @@ module dep_dry_emerson_mod use machine , only : kind_phys use dep_data_mod ! JLS - use rrfs_smoke_config, only : num_chem, p_smoke, p_dust_1, p_coarse_pm + use rrfs_smoke_config, only : num_chem, p_smoke, p_dust_1, p_coarse_pm, n_dbg_lines implicit none @@ -23,7 +23,7 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & settling_flag,drydep_flux,settling_flux,dbg_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, curr_secs, mpiid, xlat, xlong ) ! ! compute dry deposition velocity for aerosol particles ! Based on Emerson et al. (2020), PNAS, @@ -37,6 +37,9 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + + REAL(kind_phys) :: curr_secs + REAL(kind_phys), DIMENSION( ims:ime , jms:jme ) , & INTENT(IN) :: ustar, rmol, znt, snowh REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), & @@ -80,6 +83,9 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & real(kind_phys), dimension( kts:kte, ndvel ) :: cblk_col, vg_col integer, dimension(ndvel) :: ndt_settl integer :: i, j, k, ntdt, nv + integer :: icall=0 + integer, INTENT(IN) :: mpiid + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong ! chem pointers (p_*) are not sequentially numbered, need to define so nv loops work integer, dimension(ndvel) :: chem_pointers !> -- Gas constant @@ -87,11 +93,15 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & chem_pointers(1) = p_smoke chem_pointers(2) = p_dust_1 chem_pointers(3) = p_coarse_pm - + growth_fac = 1.0 conver=1.e-9 converi=1.e9 + if (mod(int(curr_secs),1800) .eq. 0) then + icall = 0 + endif + do j = jts, jte do i = its, ite aer_res(i,j) = 0.0 @@ -116,7 +126,7 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & aer_res(i,j) = max(aer_res(i,j)/100._kind_phys,0._kind_phys) ! Air kinematic viscosity (cm^2/s) airkinvisc = ( 1.8325e-4 * ( 416.16 / ( t_phy(i,k,j) + 120.0 ) ) * & - ( ( t_phy(i,k,j) / 296.16 )**1.5 ) ) / ( rho_phy(i,k,j) / 28.966e3 ) ! Convert density to mol/cm^3 + ( ( t_phy(i,k,j) / 296.16 )**1.5 ) ) / ( rho_phy(i,k,j) / 1.e3 ) ! Convert density to mol/cm^3 ! Air molecular freepath (cm) ! Check against XLM from above freepath = 7.39758e-4 * airkinvisc / sqrt( t_phy(i,k,j) ) do nv = 1, ndvel @@ -141,11 +151,11 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & amu_corrected = amu / Cc ! Gravitational Settling vg = aerodens * dp * dp * gravity * 100. * Cc / & ! Convert gravity to cm/s^2 - ( 18. * airkinvisc * ( rho_phy(i,k,j) / 28.966e3 ) ) ! Convert density to mol/cm^3 + ( 18. * airkinvisc * ( rho_phy(i,k,j) / 1.e3 ) ) ! Convert density to mol/cm^3 ! -- Rest of loop for the surface when deposition velocity needs to be cacluated if ( k == kts ) then ! Brownian Diffusion - DDp = ( boltzmann * t_phy(i,k,j) ) * Cc / (3. * pi * airkinvisc * ( rho_phy(i,k,j) / 28.966e3 ) * dp) ! Convert density to mol/cm^3 + DDp = ( boltzmann * t_phy(i,k,j) ) * Cc / (3. * pi * airkinvisc * ( rho_phy(i,k,j) / 1.e3 ) * dp) ! Convert density to mol/cm^3 ! Schmit number Sc = airkinvisc / DDp ! Brownian Diffusion @@ -179,13 +189,17 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & Rs = 1. / ( ( ustar(i,j) * 100.) * ( Eb + Eim + Ein) * eps0 ) ! Convert ustar to cm/s ! Compute final ddvel = aer_res + RS, set max at max_dep_vel in dep_data_mod.F[ m/s] ! The /100. term converts from cm/s to m/s, required for MYNN. - ddvel(i,j,nv) = min( (1. / (aer_res(i,j) + Rs ))/100., max_dep_vel) - if ( dbg_opt ) then - WRITE(6,*) 'dry_dep_mod_emerson: i,j,nv',i,j,nv - WRITE(6,*) 'dry_dep_mod_emerson: deposition velocity (m/s) ',ddvel(i,j,nv) + if ( settling_flag == 1 ) then + ddvel(i,j,nv) = max(min( ( vg + 1./(aer_res(i,j)+Rs) )/100., max_dep_vel),0._kind_phys) + else + ddvel(i,j,nv) = max(min( ( 1./(aer_res(i,j)+Rs) )/100., max_dep_vel),0._kind_phys) endif - drydep_flux(i,j,nv) = chem(i,kts,j,chem_pointers(nv))*p_phy(i,kts,j) / & - (RSI*t_phy(i,kts,j))*ddvel(i,j,nv)*dt*1.E-6 + if ( dbg_opt .and. (icall .le. n_dbg_lines) ) then + WRITE(1000+mpiid,*) 'dry_dep_mod_emer:xlat,xlong,curr_secs,nv',xlat(i,j),xlong(i,j),int(curr_secs),nv + WRITE(1000+mpiid,*) 'dry_dep_mod_emer:xlat,xlong,curr_secs,deposition velocity (m/s)',xlat(i,j),xlong(i,j),int(curr_secs),ddvel(i,j,nv) + icall = icall + 1 + endif + drydep_flux(i,j,nv) = chem(i,kts,j,chem_pointers(nv))*rho_phy(i,k,j)*ddvel(i,j,nv)/100.0*dt endif ! k == kts vgrav(i,k,j,nv) = vg ! Fill column variables @@ -220,25 +234,25 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & IF (ndt_settl(nv) > 12) ndt_settl(nv) = 12 dt_settl(nv) = REAL(ntdt,kind=kind_phys) /REAL(ndt_settl(nv),kind=kind_phys) enddo - do nv = 1, ndvel - chem_before(nv) = 0._kind_phys - do k = kts, kte - chem_before(nv) = chem_before(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 - enddo - enddo + !do nv = 1, ndvel + ! chem_before(nv) = 0._kind_phys + ! do k = kts, kte + ! chem_before(nv) = chem_before(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 + ! enddo + !enddo ! Perform gravitational settling if desired if ( settling_flag == 1 ) then call particle_settling(cblk_col,rho_col,delz_col,vg_col,dt_settl,ndt_settl,ndvel,kts,kte) endif ! Put cblk back into chem array do nv= 1, ndvel - chem_after(nv) = 0._kind_phys - settling_flux(i,j,nv) = 0._kind_phys + !chem_after(nv) = 0._kind_phys + !settling_flux(i,j,nv) = 0._kind_phys do k = kts, kte chem(i,k,j,chem_pointers(nv)) = cblk_col(k,nv) - chem_after(nv) = chem_after(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 + !chem_after(nv) = chem_after(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 enddo ! k - settling_flux(i,j,nv) = settling_flux(i,j,nv) + (chem_before(nv) - chem_after(nv)) ! ug/m2 + !settling_flux(i,j,nv) = settling_flux(i,j,nv) + (chem_before(nv) - chem_after(nv)) ! ug/m2 enddo ! nv end do ! j end do ! i diff --git a/physics/smoke_dust/dust_fengsha_mod.F90 b/physics/smoke_dust/dust_fengsha_mod.F90 index 54e66712d..6ec8f8d4a 100755 --- a/physics/smoke_dust/dust_fengsha_mod.F90 +++ b/physics/smoke_dust/dust_fengsha_mod.F90 @@ -21,8 +21,8 @@ module dust_fengsha_mod contains subroutine gocart_dust_fengsha_driver(dt, & - chem,rho_phy,smois,p8w,ssm, & - isltyp,snowh,xland,area,g,emis_dust, & + chem,rho_phy,smois,stemp,p8w,ssm, & + isltyp,snowh,xland,area,g,emis_dust, & ust,znt,clay,sand,rdrag,uthr, & num_emis_dust,num_chem,num_soil_layers, & ids,ide, jds,jde, kds,kde, & @@ -54,7 +54,7 @@ subroutine gocart_dust_fengsha_driver(dt, & REAL(kind_phys), DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN) :: rho_phy REAL(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: chem REAL(kind_phys), DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, INTENT(INOUT) :: emis_dust - REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois + REAL(kind_phys), DIMENSION( ims:ime, num_soil_layers, jms:jme ), INTENT(IN) :: smois, stemp !0d input variables REAL(kind_phys), INTENT(IN) :: dt ! time step @@ -146,6 +146,11 @@ subroutine gocart_dust_fengsha_driver(dt, & ilwi = 0 endif + ! Don't emit over frozen soil + if (stemp(i,1,j) < 268.0) then ! -5C + ilwi = 0 + endif + ! Do not allow areas with bedrock, lava, or land-ice to loft IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & diff --git a/physics/smoke_dust/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 index 95005b973..0a22fcfd7 100755 --- a/physics/smoke_dust/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -9,11 +9,11 @@ module module_add_emiss_burn subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & chem,julday,gmt,xlat,xlong, & fire_end_hr, peak_hr,time_int, & - coef_bb_dc, fhist, hwp, hwp_prevd, & + coef_bb_dc, fire_hist, hwp, hwp_prevd, & swdown,ebb_dcycle, ebu_in, ebu,fire_type,& ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte,mpiid ) IMPLICIT NONE @@ -22,6 +22,7 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN) :: mpiid real(kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(INOUT ) :: chem ! shall we set num_chem=1 here? @@ -29,7 +30,7 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & INTENT(INOUT ) :: ebu real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong, swdown - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp, peak_hr, fire_end_hr, ebu_in !, vfrac + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp, peak_hr, fire_end_hr, ebu_in !RAR: Shall we make fire_end integer? real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: coef_bb_dc ! RAR: real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: hwp_prevd @@ -38,17 +39,17 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & real(kind_phys), INTENT(IN) :: time_int,pi ! RAR: time in seconds since start of simulation INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: fire_type integer, INTENT(IN) :: ebb_dcycle ! RAR: this is going to be namelist dependent, ebb_dcycle=means - real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fhist + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fire_hist !>--local integer :: i,j,k,n,m + integer :: icall=0 real(kind_phys) :: conv_rho, conv, dm_smoke, dc_hwp, dc_gp, dc_fn !daero_num_wfa, daero_num_ifa !, lu_sum1_5, lu_sum12_14 INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise - ! real, parameter :: cx = 2.184936 * 3600., rinti = 2.1813936e-8 , ax = 2000.6038 - ! bx_bburn = 20.041288 * 3600., RAR: this depends on the vegetation class, location (local time) etc. real(kind_phys) :: timeq, fire_age, age_hr, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation - ! For Gaussian diurnal cycle + +! For Gaussian diurnal cycle real(kind_phys), PARAMETER :: sc_factor=1. ! to scale up the wildfire emissions, TBD later real(kind_phys), PARAMETER :: rinti=2.1813936e-8, ax2=3400., const2=130., & coef2=10.6712963e-4, cx2=7200., timeq_max=3600.*24. @@ -90,32 +91,39 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & ! Constants for the fire diurnal cycle calculation do j=jts,jte do i=its,ite - fire_age= time_int + (fire_end_hr(i,j))*3600. + fire_age= time_int + (fire_end_hr(i,j)-1._kind_phys)*3600._kind_phys !One hour delay is due to the latency of the RAVE files + fire_age= MAX(0._kind_phys,fire_age) SELECT CASE ( fire_type(i,j) ) !Ag, urban fires, bare land etc. CASE (1) ! these fires will have exponentially decreasing diurnal cycle, - ! We assume 1hr latency in ingesting the sat. data - coef_bb_dc(i,j) = 1._kind_phys/((2*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & - exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2*sigma_fire_dur(1)**2 )) + coef_bb_dc(i,j) = 1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & + exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) + + ! IF ( dbg_opt .AND. time_int<5000.) then + ! WRITE(6,*) 'i,j,peak_hr(i,j) ',i,j,peak_hr(i,j) + ! WRITE(6,*) 'coef_bb_dc(i,j) ',coef_bb_dc(i,j) + ! END IF + CASE (3) age_hr= fire_age/3600._kind_phys - IF (swdown(i,j)<.1 .AND. age_hr> 12. .AND. fhist(i,j)>0.75) THEN - fhist(i,j)= 0.75_kind_phys + IF (swdown(i,j)<.1 .AND. age_hr> 12. .AND. fire_hist(i,j)>0.75) THEN + fire_hist(i,j)= 0.75_kind_phys ENDIF - IF (swdown(i,j)<.1 .AND. age_hr> 24. .AND. fhist(i,j)>0.5) THEN - fhist(i,j)= 0.5_kind_phys + IF (swdown(i,j)<.1 .AND. age_hr> 24. .AND. fire_hist(i,j)>0.5) THEN + fire_hist(i,j)= 0.5_kind_phys ENDIF - IF (swdown(i,j)<.1 .AND. age_hr> 48. .AND. fhist(i,j)>0.25) THEN - fhist(i,j)= 0.25_kind_phys + IF (swdown(i,j)<.1 .AND. age_hr> 48. .AND. fire_hist(i,j)>0.25) THEN + fire_hist(i,j)= 0.25_kind_phys ENDIF ! this is based on hwp, hourly or instantenous TBD - dc_hwp= ebu_in(i,j)* hwp(i,j)/ MAX(1._kind_phys,hwp_prevd(i,j)) + dc_hwp= hwp(i,j)/ MAX(5._kind_phys,hwp_prevd(i,j)) dc_hwp= MAX(0._kind_phys,dc_hwp) + dc_hwp= MIN(25._kind_phys,dc_hwp) - !coef_bb_dc(i,j)= sc_factor* fhist(i,j)* rate_ebb2(i,j)* (1. + log( + !coef_bb_dc(i,j)= sc_factor* fire_hist(i,j)* rate_ebb2(i,j)* (1. + log( !hwp_(i,j)/ hwp_day_avg(i,j))) ! RAR: Gaussian profile for wildfires @@ -125,17 +133,30 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & dc_gp = rinti*( ax2 * exp(- dtm**2/(2._kind_phys*cx2**2) ) + const2 - coef2*timeq ) dc_gp = MAX(0._kind_phys,dc_gp) - dc_fn = MAX(dc_hwp/dc_gp,3._kind_phys) - coef_bb_dc(i,j) = fhist(i,j)* dc_fn + dc_fn = MIN(dc_hwp/dc_gp,3._kind_phys) + !coef_bb_dc(i,j) = fire_hist(i,j)* dc_fn + coef_bb_dc(i,j) = fire_hist(i,j)* dc_hwp + + ! IF ( dbg_opt .AND. time_int<5000.) then + ! WRITE(6,*) 'i,j,fire_hist(i,j),peak_hr(i,j) ', i,j,fire_hist(i,j),peak_hr(i,j) + ! WRITE(6,*) 'dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) ',dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) + ! END IF + CASE DEFAULT END SELECT enddo enddo endif + if (mod(int(time_int),1800) .eq. 0) then + icall = 0 + endif + do j=jts,jte do i=its,ite do k=kts,kfire_max + if (ebu(i,k,j)<0.001_kind_phys) cycle + if (ebb_dcycle==1) then conv= dtstep/(rho_phy(i,k,j)* dz8w(i,k,j)) elseif (ebb_dcycle==2) then @@ -143,14 +164,14 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & endif dm_smoke= conv*ebu(i,k,j) chem(i,k,j,p_smoke) = chem(i,k,j,p_smoke) + dm_smoke - chem(i,k,j,p_smoke) = MIN(chem(i,k,j,p_smoke),5.e+3) + chem(i,k,j,p_smoke) = MIN(MAX(chem(i,k,j,p_smoke),0._kind_phys),5.e+3_kind_phys) - if ( dbg_opt .and. (k==kts .OR. k==kfire_max) ) then - WRITE(6,*) 'add_emiss_burn: i,j,k ',i,j,k - WRITE(6,*) 'add_emiss_burn: rho_phy(i,k,j),dz8w(i,k,j),conv',rho_phy(i,k,j),dz8w(i,k,j),conv - WRITE(6,*) 'add_emiss_burn: ebu(i,k,j),dm_smoke ', ebu(i,k,j),dm_smoke - endif + if ( dbg_opt .and. (k==kts .OR. k==kfire_max) .and. (icall .le. n_dbg_lines) ) then + WRITE(1000+mpiid,*) 'add_emiss_burn:xlat,xlong,curr_secs,fire_type,fire_hist,peak_hr', xlat(i,j),xlong(i,j),int(time_int),fire_type(i,j),fire_hist(i,j),peak_hr(i,j) + WRITE(1000+mpiid,*) 'add_emiss_burn:xlat,xlong,curr_secs,coef_bb_dc,ebu',xlat(i,j),xlong(i,j),int(time_int),coef_bb_dc(i,j),ebu(i,k,j) + endif enddo + icall = icall + 1 enddo enddo diff --git a/physics/smoke_dust/module_plumerise.F90 b/physics/smoke_dust/module_plumerise.F90 index 8a1d6ab25..5f7ef2a0e 100755 --- a/physics/smoke_dust/module_plumerise.F90 +++ b/physics/smoke_dust/module_plumerise.F90 @@ -24,10 +24,11 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & kpbl_thetav, & ! SRB: added kpbl_thetav ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, errmsg, errflg) + its,ite, jts,jte, kts,kte, errmsg, errflg,curr_secs, & + xlat, xlong , uspdavg2, hpbl_thetav2, mpiid) use rrfs_smoke_config - use plume_data_mod + !use plume_data_mod USE module_zero_plumegen_coms USE module_smoke_plumerise IMPLICIT NONE @@ -40,6 +41,8 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & real(kind=kind_phys), DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: frp_inst ! RAR: FRP array + real(kind_phys), DIMENSION(ims:ime,jms:jme), INTENT(IN) :: xlat,xlong ! SRB + real(kind_phys), DIMENSION(ims:ime, jms:jme), INTENT(IN) :: kpbl_thetav ! SRB character(*), intent(inout) :: errmsg @@ -47,6 +50,7 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + real(kind_phys) :: curr_secs INTEGER, INTENT(IN ) :: wind_eff_opt real(kind=kind_phys), DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT ) :: ebu real(kind=kind_phys), INTENT(IN ) :: g, con_cp, con_rd @@ -57,23 +61,32 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & ! Local variables... INTEGER :: nv, i, j, k, kp1, kp2 + INTEGER :: icall=0 INTEGER, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: k_min, k_max ! Min and max ver. levels for BB injection spread + REAL, DIMENSION(ims:ime, jms:jme), INTENT (OUT) :: uspdavg2, hpbl_thetav2 ! SRB real(kind_phys), dimension (kte) :: u_in ,v_in ,w_in ,theta_in ,pi_in, rho_phyin ,qv_in ,zmid, z_lev, uspd ! SRB real(kind=kind_phys) :: dz_plume, cpor, con_rocp, uspdavg ! SRB +! MPI variables + INTEGER, INTENT(IN) :: mpiid + cpor =con_cp/con_rd con_rocp=con_rd/con_cp - IF ( dbg_opt ) then - WRITE(*,*) 'module_plumerise: its,ite,jts,jte ', its,ite,jts,jte - WRITE(*,*) 'module_plumerise: ims,ime,jms,jme ', ims,ime,jms,jme - WRITE(*,*) 'module_plumerise: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) + if (mod(int(curr_secs),1800) .eq. 0) then + icall = 0 + endif + + IF ( dbg_opt .and. icall .le. n_dbg_lines) then + WRITE(1000+mpiid,*) 'module_plumerise: its,ite,jts,jte ', its,ite,jts,jte + WRITE(1000+mpiid,*) 'module_plumerise: ims,ime,jms,jme ', ims,ime,jms,jme + WRITE(1000+mpiid,*) 'module_plumerise: maxval(ebu(:,kts,:)) ', maxval(ebu(:,kts,:)) END IF ! RAR: setting to zero the ebu emissions at the levels k>1, this is necessary when the plumerise is called, so the emissions at k>1 are updated !do nv=1,num_ebu do j=jts,jte - do k=kts+1,kte + do k=kts,kte do i=its,ite ebu(i,k,j)=0. enddo @@ -112,12 +125,10 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & uspd(k)= wind_phy(i,k,j) ! SRB enddo - IF (dbg_opt) then - WRITE(*,*) 'module_plumerise: i,j ',i,j - WRITE(*,*) 'module_plumerise: frp_inst(i,j) ',frp_inst(i,j) - WRITE(*,*) 'module_plumerise: ebu(i,kts,j) ',ebu(i,kts,j) - WRITE(*,*) 'module_plumerise: u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) ',u_in(10),v_in(10),w_in(kte),qv_in(10),pi_in(10) - WRITE(*,*) 'module_plumerise: zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) ',zmid(kte),z_lev(kte),rho_phyin(kte),theta_in(kte) + + IF (dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst(i,j) .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'module_plumerise_before:xlat,xlong,curr_secs,ebu(kts),frp_inst',xlat(i,j), xlong(i,j), int(curr_secs),ebu(i,kts,j),frp_inst(i,j) + WRITE(1000+mpiid,*) 'module_plumerise_before:xlat,xlong,curr_secs,u(10),v(10),w(10),qv(10)',xlat(i,j), xlong(i,j),int(curr_secs), u_in(10),v_in(10),w_in(kte),qv_in(10) END IF ! RAR: the plume rise calculation step: @@ -127,7 +138,8 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & wind_eff_opt, & frp_inst(i,j), k_min(i,j), & k_max(i,j), dbg_opt, g, con_cp, & - con_rd, cpor, errmsg, errflg ) + con_rd, cpor, errmsg, errflg, & + icall, mpiid, xlat(i,j), xlong(i,j), curr_secs ) if(errflg/=0) return kp1= k_min(i,j) @@ -136,9 +148,13 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & ! SRB: Adding condition for overwriting plumerise levels uspdavg=SUM(uspd(kts:kpbl_thetav(i,j)))/kpbl_thetav(i,j) !Average wind speed within the boundary layer + +! SRB: Adding output + uspdavg2(i,j) = uspdavg + hpbl_thetav2(i,j) = z_lev(kpbl_thetav(i,j)) IF ((frp_inst(i,j) .gt. frp_threshold) .AND. (frp_inst(i,j) .le. frp_threshold500) .AND. & - (z_at_w(i,kpbl_thetav(i,j),j) .gt. zpbl_threshold) .AND. (wind_eff_opt .eq. 1)) THEN + (z_lev(kpbl_thetav(i,j)) .gt. zpbl_threshold) .AND. (wind_eff_opt .eq. 1)) THEN kp1=1 IF (uspdavg .ge. uspd_threshold) THEN ! Too windy kp2=kpbl_thetav(i,j)/3 @@ -157,11 +173,18 @@ subroutine ebu_driver ( flam_frac,ebu_in,ebu, & END IF ! SRB: End modification - IF ( dbg_opt ) then - WRITE(*,*) 'module_plumerise: i,j ',i,j - WRITE(*,*) 'module_plumerise: k_min(i,j), k_max(i,j) ',kp1, kp2 ! SRB: replaced k_min, k_max with kp1, kp2 + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst(i,j) .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,k_min(i,j), k_max(i,j) ',xlat(i,j),xlong(i,j),int(curr_secs),kp1,kp2 + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,ebu(kts),frp_inst',xlat(i,j),xlong(i,j),int(curr_secs),ebu(i,kts,j),frp_inst(i,j) + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,u(10),v(10),w(10),qv(10)',xlat(i,j),xlong(i,j),int(curr_secs),u_in(10),v_in(10),w_in(kte),qv_in(10) + WRITE(1000+mpiid,*) 'mod_plumerise_after:xlat,xlong,curr_secs,uspdavg,kpbl_thetav',xlat(i,j),xlong(i,j),int(curr_secs),uspdavg,kpbl_thetav(i,j) + IF ( frp_inst(i,j) .ge. 3.e+9 ) then + WRITE(1000+mpiid,*) 'mod_plumerise_after:High FRP at : xlat,xlong,curr_secs,frp_inst',xlat(i,j),xlong(i,j),int(curr_secs),frp_inst(i,j) + END IF + icall = icall + 1 END IF -! endif check_frp +! endif check_frp +! icall = icall + 1 enddo enddo diff --git a/physics/smoke_dust/module_smoke_plumerise.F90 b/physics/smoke_dust/module_smoke_plumerise.F90 index 0fca91de4..aa45890f4 100755 --- a/physics/smoke_dust/module_smoke_plumerise.F90 +++ b/physics/smoke_dust/module_smoke_plumerise.F90 @@ -14,10 +14,11 @@ module module_smoke_plumerise use machine , only : kind_phys - use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std + !use plume_data_mod, only : num_frp_plume, p_frp_hr, p_frp_std !tropical_forest, boreal_forest, savannah, grassland, & ! wind_eff USE module_zero_plumegen_coms + USE rrfs_smoke_config, only : n_dbg_lines !real(kind=kind_phys),parameter :: rgas=r_d !real(kind=kind_phys),parameter :: cpor=cp/r_d @@ -28,12 +29,13 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & up,vp,wp,theta,pp,dn0,rv,zt_rams,zm_rams, & wind_eff_opt, & frp_inst,k1,k2, dbg_opt, g, cp, rgas, & - cpor, errmsg, errflg ) + cpor, errmsg, errflg, icall, mpiid, lat, long, curr_secs ) implicit none LOGICAL, INTENT (IN) :: dbg_opt - INTEGER, INTENT (IN) :: wind_eff_opt + INTEGER, INTENT (IN) :: wind_eff_opt, mpiid + real(kind_phys), INTENT(IN) :: lat,long, curr_secs ! SRB ! INTEGER, PARAMETER :: ihr_frp=1, istd_frp=2!, imean_fsize=3, istd_fsize=4 ! RAR: @@ -70,7 +72,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! real(kind=kind_phys), dimension(nveg_agreg) :: firesize,mean_fct INTEGER :: wind_eff - + INTEGER, INTENT(IN) :: icall type(plumegen_coms), pointer :: coms ! Set wind effect from namelist @@ -162,19 +164,11 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & endif burnt_area= max(1.0e4,burnt_area) - IF (dbg_opt) THEN - WRITE(*,*) 'plumerise: m1 ', m1 - WRITE(*,*) 'plumerise: imm, FRP,burnt_area ', imm, FRP,burnt_area - ! WRITE(*,*) 'convert_smold_to_flam ',convert_smold_to_flam - WRITE(*,*) 'plumerise: zcon ', coms%zcon - WRITE(*,*) 'plumerise: zzcon ', coms%zzcon - END IF - - IF (dbg_opt) then - WRITE(*,*) 'plumerise: imm ', imm - WRITE(*,*) 'plumerise: burnt_area ',burnt_area - END IF - + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst .ge. frp_threshold) ) THEN + WRITE(1000+mpiid,*) 'inside plumerise: xlat,xlong,curr_secs, m1 ', lat,long, int(curr_secs), m1 + WRITE(1000+mpiid,*) 'inside plumerise: xlat,xlong,curr_secs,imm,FRP,burnt_area ', lat, long, int(curr_secs), imm, FRP,burnt_area + END IF + !- get fire properties (burned area, plume radius, heating rates ...) call get_fire_properties(coms,imm,iveg_ag,burnt_area,FRP,errmsg,errflg) if(errflg/=0) return @@ -182,8 +176,8 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & !------ generates the plume rise ------ call makeplume (coms,kmt,ztopmax(imm),ixx,imm) - IF (dbg_opt) then - WRITE(*,*) 'plumerise after makeplume: imm,kmt,ztopmax(imm) ',imm,kmt,ztopmax(imm) + IF ( dbg_opt .and. (icall .le. n_dbg_lines) .and. (frp_inst .ge. frp_threshold) ) then + WRITE(1000+mpiid,*) 'inside plumerise after makeplume:xlat,xlong,curr_secs,imm,kmt,ztopmax(imm) ', lat, long, int(curr_secs), imm,kmt, ztopmax(imm) END IF enddo lp_minmax @@ -203,12 +197,12 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz, & ! enddo !enddo - IF (dbg_opt) then - WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 - WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi + !IF (dbg_opt) then + ! WRITE(*,*) 'plumerise after set_flam_vert: nkp,k1,k2, ', nkp,k1,k2 + ! WRITE(*,*) 'plumerise after set_flam_vert: dzi ', dzi !WRITE(*,*) 'plumerise after set_flam_vert: eburn_in(2) ', eburn_in(2) !WRITE(*,*) 'plumerise after set_flam_vert: eburn_out(:,2) ',eburn_out(:,2) - END IF + !END IF ! enddo lp_veg ! sub-grid vegetation, currently it's aggregated diff --git a/physics/smoke_dust/module_wetdep_ls.F90 b/physics/smoke_dust/module_wetdep_ls.F90 index 8ba8f67d9..2ef07e38c 100755 --- a/physics/smoke_dust/module_wetdep_ls.F90 +++ b/physics/smoke_dust/module_wetdep_ls.F90 @@ -31,11 +31,18 @@ subroutine wetdep_ls(dt,var,rain,moist, real(kind_phys) :: dvar,factor,clsum integer :: nv,i,j,k,km,kb,kbeg !real(kind_phys), parameter :: alpha = .5 ! scavenging factor + integer, save :: print_alpha = 0 wetdpr_smoke =0. wetdpr_dust =0. wetdpr_coarsepm=0. + !if ( print_alpha == 0 ) then + ! write(*,*) 'wetdep_ls, alpha = ',alpha + ! print_alpha = print_alpha + 1 + !endif + + do nv=1,nchem do i=its,ite do j=jts,jte @@ -76,11 +83,11 @@ subroutine wetdep_ls(dt,var,rain,moist, dvar=alpha*factor/(1+factor)*var(i,k,j,nv) ! Accumulate diags if (nv .eq. p_smoke ) then - wetdpr_smoke(i,j) = wetdpr_smoke(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + wetdpr_smoke(i,j) = wetdpr_smoke(i,j) + dvar * rho(i,k,j) / dt elseif (nv .eq. p_dust_1 ) then - wetdpr_dust(i,j) = wetdpr_dust(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + wetdpr_dust(i,j) = wetdpr_dust(i,j) + dvar * rho(i,k,j) / dt elseif (nv .eq. p_coarse_pm ) then - wetdpr_coarsepm(i,j) = wetdpr_coarsepm(i,j) + dvar * rho(i,k,j) * dt * 1.E-6 + wetdpr_coarsepm(i,j) = wetdpr_coarsepm(i,j) + dvar * rho(i,k,j) / dt endif var(i,k,j,nv)=max(1.e-16,var(i,k,j,nv)-dvar) endif diff --git a/physics/smoke_dust/plume_data_mod.F90 b/physics/smoke_dust/plume_data_mod.F90 deleted file mode 100755 index 3f0bcdecd..000000000 --- a/physics/smoke_dust/plume_data_mod.F90 +++ /dev/null @@ -1,51 +0,0 @@ -!>\file plume_data_mod.F90 -!! This file contains data for the fire plume rise module. - -module plume_data_mod - - use machine , only : kind_phys - - implicit none - - ! -- FRP parameters - integer, dimension(0:20), parameter :: & - catb = (/ & - 0, & - 2, 1, 2, 1, & !floresta tropical 2 and 4 / extra trop fores 1,3,5 - 2, 3, 3, 3, 3, & !cerrado/woody savanna :6 a 9 - 4, 4, 4, 4, 4, 0, 4, 0, 0, 0, 0 & !pastagem/lavouras: 10 ... - /) - - real(kind=kind_phys), dimension(0:4), parameter :: & - flaming = (/ & - 0.00, & ! - 0.45, & ! % biomass burned at flaming phase : tropical forest igbp 2 and 4 - 0.45, & ! % biomass burned at flaming phase : extratropical forest igbp 1 , 3 and 5 - 0.75, & ! % biomass burned at flaming phase : cerrado/woody savanna igbp 6 to 9 - 0.00 & ! % biomass burned at flaming phase : pastagem/lavoura: igbp 10 a 17 - /) - - real(kind=kind_phys), dimension(0:20), parameter :: & - msize= (/ & - 0.00021, & !0near water,1Evergreen needleleaf,2EvergreenBroadleaf,!3Deciduous Needleleaf,4Deciduous Broadleaf - 0.00021, 0.00021, 0.00021, 0.00021, & !5Mixed forest,6Closed shrublands,7Open shrublands,8Woody savannas,9Savannas, - 0.00023, 0.00022, 0.00022, 0.00022, 0.00029, &! 10Grassland,11Permanent wetlands,12cropland,13'Urban and Built-Up' - 0.00029, 0.00021, 0.00026, 0.00021, 0.00026, &!14cropland/natural vegetation mosaic,15Snow and ice,16Barren or sparsely vegetated - 0.00021, 0.00021, 0.00021, 0.00021, 0.00021, 0.00021 & !17Water,18Wooded Tundra,19Mixed Tundra,20Bare Ground Tundra - /) - - ! -- FRP buffer indices - integer, parameter :: p_frp_hr = 1 - integer, parameter :: p_frp_std = 2 - integer, parameter :: num_frp_plume = 2 - - ! -- plumerise parameters - integer, parameter :: tropical_forest = 1 - integer, parameter :: boreal_forest = 2 - integer, parameter :: savannah = 3 - integer, parameter :: grassland = 4 - integer, parameter :: nveg_agreg = 4 - - public - -end module plume_data_mod diff --git a/physics/smoke_dust/rrfs_smoke_config.F90 b/physics/smoke_dust/rrfs_smoke_config.F90 index d7478986b..dae4338bb 100755 --- a/physics/smoke_dust/rrfs_smoke_config.F90 +++ b/physics/smoke_dust/rrfs_smoke_config.F90 @@ -24,6 +24,7 @@ module rrfs_smoke_config integer :: addsmoke_flag = 1 integer :: smoke_forecast = 1 integer :: plumerisefire_frq=60 + integer :: n_dbg_lines = 3 integer :: wetdep_ls_opt = 1 integer :: drydep_opt = 1 integer :: pm_settling = 1 @@ -39,7 +40,7 @@ module rrfs_smoke_config ! -- integer, parameter :: CHEM_OPT_GOCART= 1 - integer, parameter :: num_moist=2, num_chem=20, num_emis_seas=5, num_emis_dust=5 + integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 ! -- hydrometeors integer, parameter :: p_qv=1 diff --git a/physics/smoke_dust/rrfs_smoke_postpbl.meta b/physics/smoke_dust/rrfs_smoke_postpbl.meta index 50fbb4e03..8d7481ec4 100755 --- a/physics/smoke_dust/rrfs_smoke_postpbl.meta +++ b/physics/smoke_dust/rrfs_smoke_postpbl.meta @@ -1,8 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_postpbl type = scheme - dependencies = ../hooks/machine.F,dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,dep_dry_mod_emerson.F90,dep_data_mod.F90 - + dependencies = dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## [ccpp-arg-table] name = rrfs_smoke_postpbl_run diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index eb7f83af6..4daad7168 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -12,7 +12,7 @@ module rrfs_smoke_wrapper ebb_dcycle, extended_sd_diags,add_fire_heat_flux, & num_moist, num_chem, num_emis_seas, num_emis_dust, & p_qv, p_atm_shum, p_atm_cldq, & - p_smoke, p_dust_1, p_coarse_pm, epsilc + p_smoke, p_dust_1, p_coarse_pm, epsilc, n_dbg_lines use dust_data_mod, only : dust_alpha, dust_gamma, dust_moist_opt, & dust_moist_correction, dust_drylimit_factor use seas_mod, only : gocart_seasalt_driver @@ -52,7 +52,7 @@ subroutine rrfs_smoke_wrapper_init( seas_opt_in, dust_moist_correction_in, dust_drylimit_factor_in, & ! Dust namelist aero_ind_fdb_in, & ! Feedback namelist extended_sd_diags_in,dbg_opt_in, & ! Other namelist - errmsg, errflg ) + errmsg, errflg, n_dbg_lines_in ) !>-- Namelist @@ -62,7 +62,7 @@ subroutine rrfs_smoke_wrapper_init( seas_opt_in, integer, intent(in) :: dust_opt_in,dust_moist_opt_in, wetdep_ls_opt_in, pm_settling_in, seas_opt_in integer, intent(in) :: drydep_opt_in logical, intent(in) :: aero_ind_fdb_in,dbg_opt_in, extended_sd_diags_in, add_fire_heat_flux_in - integer, intent(in) :: smoke_forecast_in, plume_wind_eff_in, plumerisefire_frq_in + integer, intent(in) :: smoke_forecast_in, plume_wind_eff_in, plumerisefire_frq_in, n_dbg_lines_in integer, intent(in) :: addsmoke_flag_in, ebb_dcycle_in logical, intent(in) :: do_plumerise_in, rrfs_sd character(len=*),intent(out):: errmsg @@ -100,6 +100,7 @@ subroutine rrfs_smoke_wrapper_init( seas_opt_in, !>-Other extended_sd_diags = extended_sd_diags_in dbg_opt = dbg_opt_in + n_dbg_lines = n_dbg_lines_in end subroutine rrfs_smoke_wrapper_init @@ -111,17 +112,19 @@ end subroutine rrfs_smoke_wrapper_init subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, & u10m, v10m, ustar, rlat, rlon, tskin, pb2d, t2m, dpt2m, & pr3d, ph3d,phl3d, prl3d, tk3d, us3d, vs3d, spechum, w, & - nsoil, smc, vegtype_dom, vegtype_frac, soiltyp, nlcat, & + nsoil, smc, tslb, vegtype_dom, vegtype_frac, soiltyp, nlcat, & dswsfc, zorl, snow, julian,recmol, & idat, rain_cpl, rainc_cpl, hf2d, g, pi, con_cp, con_rd, con_fv, & dust12m_in, emi_ant_in, smoke_RRFS, smoke2d_RRFS, & ntrac, qgrs, gq0, chem3d, tile_num, & ntsmoke, ntdust, ntcoarsepm, imp_physics, imp_physics_thompson, & nwfa, nifa, emanoc, emdust, emseas, drydep_flux_out, wetdpr, & - ebb_smoke_in, frp_output, coef_bb, ebu_smoke,fhist,min_fplume, & + ebb_smoke_in, frp_output, coef_bb, fire_type_out, & + ebu_smoke,fhist,min_fplume, & max_fplume, hwp, hwp_ave, wetness, ndvel, ddvel_inout,fire_in, & + peak_hr_out,lu_nofire_out,lu_qfire_out, & fire_heat_flux_out, frac_grid_burned_out, kpbl,oro, & - errmsg,errflg ) + uspdavg, hpbl_thetav, mpicomm, mpirank, mpiroot, errmsg,errflg ) implicit none @@ -135,7 +138,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, integer, parameter :: its=1,jts=1,jte=1, kts=1 integer, dimension(:), intent(in) :: land, vegtype_dom, soiltyp - real(kind_phys), dimension(:,:), intent(in) :: smc + real(kind_phys), dimension(:,:), intent(in) :: smc, tslb real(kind_phys), dimension(:,:,:), intent(in) :: dust12m_in real(kind_phys), dimension(:,:,:), intent(in) :: smoke_RRFS real(kind_phys), dimension(:,:), intent(in) :: smoke2d_RRFS @@ -153,14 +156,16 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke real(kind_phys), dimension(:,:), intent(inout) :: fire_in real(kind_phys), dimension(:), intent(out) :: fire_heat_flux_out, frac_grid_burned_out - real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume - real(kind_phys), dimension(:), intent( out) :: hwp + real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume, uspdavg, hpbl_thetav + real(kind_phys), dimension(:), intent(inout) :: hwp, peak_hr_out real(kind_phys), dimension(:), intent(inout) :: hwp_ave real(kind_phys), dimension(:,:), intent(inout) :: nwfa, nifa real(kind_phys), dimension(:,:), intent(inout) :: ddvel_inout real(kind_phys), dimension(:,:), intent(inout) :: drydep_flux_out real(kind_phys), dimension(:,:), intent(inout) :: wetdpr real(kind_phys), dimension(:), intent(in) :: wetness + real(kind_phys), dimension(:), intent(out) :: lu_nofire_out,lu_qfire_out + integer, dimension(:), intent(out) :: fire_type_out integer, intent(in) :: imp_physics, imp_physics_thompson integer, dimension(:), intent(in) :: kpbl real(kind_phys), dimension(:), intent(in) :: oro @@ -187,16 +192,17 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(ims:im, jms:jme) :: ssm, rdrag, uthr, snowh ! fengsha dust real(kind_phys), dimension(ims:im, jms:jme) :: rmol, swdown, znt, clayf, sandf real(kind_phys), dimension(ims:im, nlcat, jms:jme) :: vegfrac - real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois + real(kind_phys), dimension(ims:im, nsoil, jms:jme) :: smois, stemp real(kind_phys), dimension(ims:im, 1:1, jms:jme, 1:num_emis_dust) :: emis_dust integer, dimension(ims:im, jms:jme) :: isltyp, ivgtyp !>- plume variables ! -- buffers real(kind_phys), dimension(ims:im, jms:jme ) :: coef_bb_dc, flam_frac, frp_in, & fire_hist, peak_hr, lu_nofire, lu_qfire, ebu_in, & - fire_end_hr, hwp_day_avg, kpbl_thetav + fire_end_hr, hwp_day_avg, kpbl_thetav,& + uspdavg2, hpbl_thetav2 integer, dimension(ims:im, jms:jme ) :: min_fplume2, max_fplume2, fire_type - logical :: call_plume, reset_hwp_ave + logical :: call_plume, reset_hwp_ave, avg_hwp_ave !>- optical variables real(kind_phys), dimension(ims:im, jms:jme, ndvel) :: ddvel, settling_flux, drydep_flux_local real(kind_phys), dimension(ims:im, kms:kme, jms:jme, ndvel) :: vgrav @@ -218,6 +224,13 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys) :: factor, factor2, factor3 integer :: nbegin, nv integer :: i, j, k, kp, n +! MPI variables + integer :: mpiid + integer, intent(in) :: mpicomm + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + + mpiid = mpirank errmsg = '' errflg = 0 @@ -232,6 +245,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, min_fplume2 = 0 max_fplume2 = 0 + uspdavg2 = 0. + hpbl_thetav2 = 0. emis_seas = 0. emis_dust = 0. peak_hr = 0. @@ -260,12 +275,17 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! -- compute incremental convective and large-scale rainfall do i=its,ite rnav(i,1)=max((rain_cpl(i)-rainc_cpl(i))*1000., 0.) ! meter to mm +! coef_bb initializes as clear_val (from GFS_typedefs.F90) +! at ktau = 1, coef_bb_dc is set = 1.0 coef_bb_dc(i,1) = coef_bb(i) +! fhist initializes as 1. (from GFS_typedefs.F90) fire_hist (i,1) = fhist (i) + peak_hr (i,1) = peak_hr_out(i) enddo ! Is this a reset timestep (00:00 + dt)? reset_hwp_ave = mod(int(curr_secs-dt),3600) == 0 + avg_hwp_ave = mod(int(curr_secs),3600) == 0 ! plumerise frequency in minutes set up by the namelist input call_plume = (do_plumerise .and. (plumerisefire_frq > 0)) @@ -276,7 +296,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ktau,current_month, current_hour, gmt, con_rd, con_fv, con_cp, & u10m,v10m,ustar,land,garea,rlat,rlon,tskin, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & - nsoil,smc,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & + nsoil,smc,tslb,vegtype_dom,soiltyp, & + nlcat,vegtype_frac,dswsfc,zorl, & snow,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & hf2d, pb2d, g, pi, hour_int, peak_hr, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & @@ -287,20 +308,14 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, num_chem,num_moist, & ntsmoke, ntdust,ntcoarsepm, & moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & - fhist,frp_in, hwp_day_avg, fire_end_hr, & - emis_anoc,smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,oro, hwp_local, & + fire_hist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,stemp,ivgtyp,isltyp,vegfrac,rmol,swdown,znt, & + hfx,pbl,snowh,clayf,rdrag,sandf,ssm,uthr,oro, hwp_local, & t2m,dpt2m,wetness,kpbl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - do j=jts,jte - do i=its,ite - peak_hr(i,j)= fire_in(i,1) - enddo - enddo - IF (ktau==1) THEN ebu = 0. do j=jts,jte @@ -311,6 +326,13 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, enddo enddo enddo + ELSE + do k=kts,kte + do i=its,ite + ! ebu is divided by coef_bb_dc since it is applied in the output + ebu(i,k,1)=ebu_smoke(i,k) / coef_bb_dc(i,1) + enddo + enddo ENDIF !RAR: change this to the fractional LU type; fire_type: 0- no fires, 1- Ag @@ -320,6 +342,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, do i=its,ite if (ebu_in(i,j)<0.01) then fire_type(i,j) = 0 + lu_nofire(i,j) = 1.0 else ! Permanent wetlands, snow/ice, water, barren tundra lu_nofire(i,j) = vegfrac(i,11,j) + vegfrac(i,15,j) + vegfrac(i,17,j) + vegfrac(i,20,j) @@ -350,9 +373,10 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, endif !-- compute dust (opt=5) - if (dust_opt==5) then - call gocart_dust_fengsha_driver(dt,chem,rho_phy,smois,p8w,ssm, & - isltyp,snowh,xland,dxy,g,emis_dust,ust,znt, & + if (dust_opt==1) then + call gocart_dust_fengsha_driver(dt,chem,rho_phy, & + smois,stemp,p8w,ssm, & + isltyp,snowh,xland,dxy,g,emis_dust,ust,znt, & clayf,sandf,rdrag,uthr, & num_emis_dust,num_chem,nsoil, & ids,ide, jds,jde, kds,kde, & @@ -367,6 +391,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, ! Every hour (per namelist) the ebu_driver is called to calculate ebu, but ! the plumerise is controlled by the namelist option of plumerise_flag if (add_fire_heat_flux) then + WRITE(1000+mpiid,*) 'Entered add_fire_heat_flux at timestep:',ktau do i = its,ite if ( coef_bb_dc(i,1)*frp_in(i,1) .ge. 1.E7 ) then fire_heat_flux_out(i) = min(max(0.,0.88*coef_bb_dc(i,1)*frp_in(i,1) / & @@ -396,7 +421,8 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, kpbl_thetav, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, errmsg, errflg ) + its,ite, jts,jte, kts,kte, errmsg, errflg, curr_secs, & + xlat, xlong, uspdavg2, hpbl_thetav2, mpiid ) if(errflg/=0) return end if @@ -409,7 +435,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, swdown,ebb_dcycle,ebu_in,ebu,fire_type, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte , mpiid ) endif !>-- compute coarsepm setting if using simple dry dep option and @@ -431,7 +457,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, pm_settling,drydep_flux_local,settling_flux,dbg_opt, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, curr_secs, mpiid, xlat, xlong ) do nv=1,ndvel do i=its,ite ddvel_inout(i,nv)=ddvel(i,1,nv) @@ -470,10 +496,12 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, endif endif -! Smoke emisisons diagnostic +! Smoke emisisons diagnostic, RAR: let's multiply by coef_bb_dc before output +! Since ebu_smoke includes coef_bb_dc, we need to divide by coef_bb_dc when it +! comes back into the wrapper. do k=kts,kte do i=its,ite - ebu_smoke(i,k)=ebu(i,k,1) + ebu_smoke(i,k)=ebu(i,k,1) * coef_bb_dc(i,1) enddo enddo @@ -485,15 +513,21 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, do i=its,ite hwp(i)=hwp_local(i,1) hwp_ave(i) = hwp_ave(i) + hwp(i)*dt + if ( ktau == 1) then + hwp_ave(i) = hwp_ave(i) / dt + elseif ( avg_hwp_ave ) then + hwp_ave(i) = hwp_ave(i) / 3600._kind_phys + endif enddo - + + !---- diagnostic output of dry deposition & gravitational settling fluxes if ( drydep_opt == 1 .and. (extended_sd_diags .or. dbg_opt) ) then do nv = 1, ndvel do i=its,ite drydep_flux_out(i,nv) = drydep_flux_out(i,nv) + & - drydep_flux_local(i,1,nv) + & - settling_flux(i,1,nv) + drydep_flux_local(i,1,nv) !+ & + !settling_flux(i,1,nv) enddo enddo endif @@ -520,6 +554,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, !------------------------------------- !-- to output for diagnostics do i = 1, im +! RAR: let's remove the seas and ant. OC emseas (i) = emis_seas(i,1,1,1)*1.e+9 ! size bin 1 sea salt emission: ug/m2/s emanoc (i) = emis_anoc (i) ! anthropogenic organic carbon: ug/m2/s emdust (i) = emis_dust(i,1,1,1) + emis_dust(i,1,1,2) + & @@ -529,10 +564,13 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, fhist (i) = fire_hist (i,1) min_fplume (i) = real(min_fplume2(i,1)) max_fplume (i) = real(max_fplume2(i,1)) + fire_type_out(i)=fire_type(i,1) + lu_nofire_out(i)=lu_nofire(i,1) + lu_qfire_out (i)=lu_qfire(i,1) enddo do i = 1, im - fire_in(i,1) = peak_hr(i,1) + peak_hr_out(i) = peak_hr(i,1) enddo !-- to provide real aerosol emission for Thompson MP @@ -568,7 +606,7 @@ subroutine rrfs_smoke_prep( & ktau,current_month,current_hour,gmt,con_rd,con_fv,con_cp, & u10m,v10m,ustar,land,garea,rlat,rlon,ts2d, & pr3d,ph3d,phl3d,tk3d,prl3d,us3d,vs3d,spechum,w, & - nsoil,smc,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & + nsoil,smc,tslb,vegtype_dom,soiltyp,nlcat,vegtype_frac,dswsfc,zorl, & snow_cpl,dust12m_in,emi_ant_in,smoke_RRFS,smoke2d_RRFS,coef_bb_dc, & hf2d, pb2d, g, pi, hour_int, peak_hr, & u10,v10,ust,tsk,xland,xlat,xlong,dxy, & @@ -579,9 +617,9 @@ subroutine rrfs_smoke_prep( & num_chem, num_moist, & ntsmoke, ntdust, ntcoarsepm, & moist,chem,ebu_in,kpbl_thetav,ebb_smoke_in, & - fhist,frp_in, hwp_day_avg, fire_end_hr, & - emis_anoc,smois,ivgtyp,isltyp,vegfrac,rmol,swdown,znt,hfx,pbl, & - snowh,clayf,rdrag,sandf,ssm,uthr,oro,hwp_local, & + fire_hist,frp_in, hwp_day_avg, fire_end_hr, & + emis_anoc,smois,stemp,ivgtyp,isltyp,vegfrac,rmol,swdown, & + znt,hfx,pbl,snowh,clayf,rdrag,sandf,ssm,uthr,oro,hwp_local, & t2m,dpt2m,wetness,kpbl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -599,7 +637,7 @@ subroutine rrfs_smoke_prep( & u10m, v10m, ustar, garea, rlat, rlon, ts2d, dswsfc, & zorl, snow_cpl, pb2d, hf2d, oro, t2m, dpt2m, wetness, recmol real(kind=kind_phys), dimension(ims:ime, nlcat), intent(in) :: vegtype_frac - real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc + real(kind=kind_phys), dimension(ims:ime, nsoil), intent(in) :: smc,tslb real(kind=kind_phys), dimension(ims:ime, 12, 5), intent(in) :: dust12m_in real(kind=kind_phys), dimension(ims:ime, 24, 2), intent(in) :: smoke_RRFS ! This is a place holder for ebb_dcycle == 2, currently set to hold a single @@ -633,8 +671,8 @@ subroutine rrfs_smoke_prep( & real(kind_phys), dimension(ims:ime, kms:kme, jms:jme, num_chem), intent(out) :: chem real(kind_phys), dimension(ims:ime, kms:kme, jms:jme), intent(out) :: z_at_w - real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois - real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: frp_in, fire_end_hr, fhist, coef_bb_dc + real(kind_phys), dimension(ims:ime, nsoil, jms:jme), intent(out) :: smois,stemp + real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: frp_in, fire_end_hr, fire_hist, coef_bb_dc real(kind_phys), dimension(ims:ime,jms:jme), intent(inout) :: hwp_day_avg, peak_hr real(kind_phys), dimension(ims:ime), intent(inout) :: emis_anoc,ebb_smoke_in real(kind_phys), parameter :: conv_frp = 1.e+06_kind_phys ! FRP conversion factor, MW to W @@ -730,6 +768,7 @@ subroutine rrfs_smoke_prep( & do j=jts,jte do i=its,ite smois(i,k,j)=smc(i,k) + stemp(i,k,j)=tslb(i,k) enddo enddo enddo @@ -776,13 +815,14 @@ subroutine rrfs_smoke_prep( & rri(i,k,j)=1./rho_phy(i,k,j) vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. - moist(i,k,j,1)=gq0(i,kkp,p_atm_shum) - if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(i,kkp,p_atm_cldq) + moist(i,k,j,1)=gq0(i,kkp,1) + !if (t_phy(i,k,j) > 265.) then + moist(i,k,j,2)=gq0(i,kkp,2) if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. - else - moist(i,k,j,2)=0. - endif + !else + ! moist(i,k,j,2)=0. + if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. + !endif !-- zmid(i,k,j)=phl3d(i,kkp)/g enddo @@ -862,11 +902,11 @@ subroutine rrfs_smoke_prep( & if (hour_int .le. 24) then do j=jts,jte do i=its,ite - ebu_in (i,j) = smoke_RRFS(i,hour_int+1,1) ! smoke frp_in (i,j) = smoke_RRFS(i,hour_int+1,2)*conv_frp ! frp - fire_end_hr(i,j) = 0.0 - hwp_day_avg(i,j) = 0.0 + ! These 2 arrays aren't needed for this option + ! fire_end_hr(i,j) = 0.0 + ! hwp_day_avg(i,j) = 0.0 ebb_smoke_in (i) = ebu_in(i,j) enddo enddo @@ -890,7 +930,8 @@ subroutine rrfs_smoke_prep( & if (ktau==1) then do j=jts,jte do i=its,ite - fhist (i,j) = 1. + ! GFS_typedefs.F90 initializes this = 1, but should be OK to duplicate, RAR?? + fire_hist (i,j) = 1. coef_bb_dc (i,j) = 1. if (xlong(i,j)<230.) then peak_hr(i,j)= 0.0* 3600. ! peak at 24 UTC, fires in Alaska @@ -909,7 +950,7 @@ subroutine rrfs_smoke_prep( & enddo endif - ! We will add a namelist variable, real :: flam_frac_global + ! We will add a namelist variable, real :: flam_frac_global, RAR?? do k=kms,kte do i=ims,ime chem(i,k,jts,p_smoke )=max(epsilc,gq0(i,k,ntsmoke )) diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index af61ac05e..fc3aa9fe6 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = rrfs_smoke_wrapper type = scheme - dependencies = ../hooks/machine.F,dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,plume_data_mod.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90, dep_dry_mod_emerson.F90,dep_data_mod.F90 + dependencies = dep_dry_simple_mod.F90,module_wetdep_ls.F90,dust_data_mod.F90,dust_fengsha_mod.F90,module_add_emiss_burn.F90,module_plumerise.F90,module_smoke_plumerise.F90,module_zero_plumegen_coms.F90,rrfs_smoke_config.F90,seas_data_mod.F90,seas_mod.F90,seas_ngac_mod.F90,coarsepm_settling_mod.F90, dep_dry_mod_emerson.F90,dep_data_mod.F90 ######################################################################## [ccpp-arg-table] @@ -71,6 +71,13 @@ dimensions = () type = integer intent = in +[n_dbg_lines_in] + standard_name = smoke_debug_lines + long_name = rrfs smoke add smoke option + units = index + dimensions = () + type = integer + intent = in [plume_wind_eff_in] standard_name = option_for_wind_effects_on_smoke_plumerise long_name = wind effect plumerise option @@ -406,6 +413,14 @@ type = real kind = kind_phys intent = inout +[tslb] + standard_name = soil_temperature_for_land_surface_model + long_name = soil temperature for land surface model + units = K + dimensions = (horizontal_loop_extent,vertical_dimension_of_soil_internal_to_land_surface_scheme) + type = real + kind = kind_phys + intent = in [vegtype_dom] standard_name = vegetation_type_classification long_name = vegetation type at each grid cell @@ -715,6 +730,13 @@ type = real kind = kind_phys intent = inout +[fire_type_out] + standard_name = fire_type_out + long_name = type of fire + units = none + dimensions = (horizontal_loop_extent) + type = integer + intent = out [ebu_smoke] standard_name = ebu_smoke long_name = buffer of vertical fire emission @@ -747,6 +769,43 @@ type = real kind = kind_phys intent = inout +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = integer + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[uspdavg] + standard_name = bl_averaged_wind_speed + long_name = average wind speed within the boundary layer + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[hpbl_thetav] + standard_name = pbl_height_thetav + long_name = pbl height based on modified parcel method + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout [drydep_flux_out] standard_name = dry_deposition_flux long_name = rrfs dry deposition flux @@ -810,6 +869,30 @@ type = real kind = kind_phys intent = inout +[peak_hr_out] + standard_name = peak_hr_fire + long_name = hour of peak fire emissions + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lu_nofire_out] + standard_name = lu_nofire_out + long_name = land use of no fire pixels for type + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[lu_qfire_out] + standard_name = lu_qfire_out + long_name = land use of fire pixels for type + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out [fire_heat_flux_out] standard_name = surface_fire_heat_flux long_name = heat flux of fire at the surface From c0544c218776d4a94169d45cb7dae102800594a1 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Tue, 23 Jan 2024 16:13:19 +0000 Subject: [PATCH 59/64] "update to address code reviewer's comments" --- physics/smoke_dust/dep_dry_mod_emerson.F90 | 14 ---------- physics/smoke_dust/module_add_emiss_burn.F90 | 27 +++++++++---------- physics/smoke_dust/rrfs_smoke_config.F90 | 2 +- physics/smoke_dust/rrfs_smoke_wrapper.F90 | 14 +++------- physics/smoke_dust/rrfs_smoke_wrapper.meta | 28 +++++++------------- 5 files changed, 27 insertions(+), 58 deletions(-) diff --git a/physics/smoke_dust/dep_dry_mod_emerson.F90 b/physics/smoke_dust/dep_dry_mod_emerson.F90 index 771801c44..e69d6bc3f 100755 --- a/physics/smoke_dust/dep_dry_mod_emerson.F90 +++ b/physics/smoke_dust/dep_dry_mod_emerson.F90 @@ -179,10 +179,6 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & eps0 = eps0_grs end if ! Set if snow greater than 1 cm -! if ( snowh(i,j) .gt. 0.01 ) then ! snow -! A = A_wat -! eps0 = eps0_wat -! endif ! Interception Ein = Cin * ( dp / A )**vv ! Surface resistance @@ -234,25 +230,15 @@ subroutine dry_dep_driver_emerson(rmol,ustar,znt,ndvel,ddvel,vgrav, & IF (ndt_settl(nv) > 12) ndt_settl(nv) = 12 dt_settl(nv) = REAL(ntdt,kind=kind_phys) /REAL(ndt_settl(nv),kind=kind_phys) enddo - !do nv = 1, ndvel - ! chem_before(nv) = 0._kind_phys - ! do k = kts, kte - ! chem_before(nv) = chem_before(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 - ! enddo - !enddo ! Perform gravitational settling if desired if ( settling_flag == 1 ) then call particle_settling(cblk_col,rho_col,delz_col,vg_col,dt_settl,ndt_settl,ndvel,kts,kte) endif ! Put cblk back into chem array do nv= 1, ndvel - !chem_after(nv) = 0._kind_phys - !settling_flux(i,j,nv) = 0._kind_phys do k = kts, kte chem(i,k,j,chem_pointers(nv)) = cblk_col(k,nv) - !chem_after(nv) = chem_after(nv) + (cblk_col(k,nv) * rho_phy(i,k,j) * delz(i,k,j) ) ! ug/m2 enddo ! k - !settling_flux(i,j,nv) = settling_flux(i,j,nv) + (chem_before(nv) - chem_after(nv)) ! ug/m2 enddo ! nv end do ! j end do ! i diff --git a/physics/smoke_dust/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 index 0a22fcfd7..f1bbaeee9 100755 --- a/physics/smoke_dust/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -47,7 +47,7 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & INTEGER, PARAMETER :: kfire_max=51 ! max vertical level for BB plume rise - real(kind_phys) :: timeq, fire_age, age_hr, dt1,dt2,dtm ! For BB emis. diurnal cycle calculation + real(kind_phys) :: timeq, fire_age, age_hr, dt1,dt2,dtm, coef_con ! For BB emis. diurnal cycle calculation ! For Gaussian diurnal cycle real(kind_phys), PARAMETER :: sc_factor=1. ! to scale up the wildfire emissions, TBD later @@ -89,6 +89,8 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & if (ebb_dcycle==2) then ! Constants for the fire diurnal cycle calculation + coef_con = 1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & + exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) do j=jts,jte do i=its,ite fire_age= time_int + (fire_end_hr(i,j)-1._kind_phys)*3600._kind_phys !One hour delay is due to the latency of the RAVE files @@ -97,13 +99,12 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & SELECT CASE ( fire_type(i,j) ) !Ag, urban fires, bare land etc. CASE (1) ! these fires will have exponentially decreasing diurnal cycle, - coef_bb_dc(i,j) = 1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & - exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) + coef_bb_dc(i,j) = coef_con - ! IF ( dbg_opt .AND. time_int<5000.) then - ! WRITE(6,*) 'i,j,peak_hr(i,j) ',i,j,peak_hr(i,j) - ! WRITE(6,*) 'coef_bb_dc(i,j) ',coef_bb_dc(i,j) - ! END IF + IF ( dbg_opt .AND. time_int<5000.) then + WRITE(6,*) 'i,j,peak_hr(i,j) ',i,j,peak_hr(i,j) + WRITE(6,*) 'coef_bb_dc(i,j) ',coef_bb_dc(i,j) + END IF CASE (3) age_hr= fire_age/3600._kind_phys @@ -123,9 +124,6 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & dc_hwp= MAX(0._kind_phys,dc_hwp) dc_hwp= MIN(25._kind_phys,dc_hwp) - !coef_bb_dc(i,j)= sc_factor* fire_hist(i,j)* rate_ebb2(i,j)* (1. + log( - !hwp_(i,j)/ hwp_day_avg(i,j))) - ! RAR: Gaussian profile for wildfires dt1= abs(timeq - peak_hr(i,j)) dt2= timeq_max - peak_hr(i,j) + timeq ! peak hour is always <86400. @@ -134,13 +132,12 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & dc_gp = MAX(0._kind_phys,dc_gp) dc_fn = MIN(dc_hwp/dc_gp,3._kind_phys) - !coef_bb_dc(i,j) = fire_hist(i,j)* dc_fn coef_bb_dc(i,j) = fire_hist(i,j)* dc_hwp - ! IF ( dbg_opt .AND. time_int<5000.) then - ! WRITE(6,*) 'i,j,fire_hist(i,j),peak_hr(i,j) ', i,j,fire_hist(i,j),peak_hr(i,j) - ! WRITE(6,*) 'dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) ',dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) - ! END IF + IF ( dbg_opt .AND. time_int<5000.) then + WRITE(6,*) 'i,j,fire_hist(i,j),peak_hr(i,j) ', i,j,fire_hist(i,j),peak_hr(i,j) + WRITE(6,*) 'dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) ',dc_gp,dc_hwp,dc_fn,coef_bb_dc(i,j) + END IF CASE DEFAULT END SELECT diff --git a/physics/smoke_dust/rrfs_smoke_config.F90 b/physics/smoke_dust/rrfs_smoke_config.F90 index dae4338bb..c20d6e2db 100755 --- a/physics/smoke_dust/rrfs_smoke_config.F90 +++ b/physics/smoke_dust/rrfs_smoke_config.F90 @@ -40,7 +40,7 @@ module rrfs_smoke_config ! -- integer, parameter :: CHEM_OPT_GOCART= 1 - integer, parameter :: num_moist=3, num_chem=20, num_emis_seas=5, num_emis_dust=5 + integer, parameter :: num_moist=2, num_chem=20, num_emis_seas=5, num_emis_dust=5 ! -- hydrometeors integer, parameter :: p_qv=1 diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.F90 b/physics/smoke_dust/rrfs_smoke_wrapper.F90 index 4daad7168..3842cba54 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.F90 +++ b/physics/smoke_dust/rrfs_smoke_wrapper.F90 @@ -121,7 +121,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, nwfa, nifa, emanoc, emdust, emseas, drydep_flux_out, wetdpr, & ebb_smoke_in, frp_output, coef_bb, fire_type_out, & ebu_smoke,fhist,min_fplume, & - max_fplume, hwp, hwp_ave, wetness, ndvel, ddvel_inout,fire_in, & + max_fplume, hwp, hwp_ave, wetness, ndvel, ddvel_inout, & peak_hr_out,lu_nofire_out,lu_qfire_out, & fire_heat_flux_out, frac_grid_burned_out, kpbl,oro, & uspdavg, hpbl_thetav, mpicomm, mpirank, mpiroot, errmsg,errflg ) @@ -154,8 +154,7 @@ subroutine rrfs_smoke_wrapper_run(im, kte, kme, ktau, dt, garea, land, jdate, real(kind_phys), dimension(:), intent(inout) :: emdust, emseas, emanoc real(kind_phys), dimension(:), intent(inout) :: ebb_smoke_in,coef_bb, frp_output, fhist real(kind_phys), dimension(:,:), intent(inout) :: ebu_smoke - real(kind_phys), dimension(:,:), intent(inout) :: fire_in - real(kind_phys), dimension(:), intent(out) :: fire_heat_flux_out, frac_grid_burned_out + real(kind_phys), dimension(:), intent(out ) :: fire_heat_flux_out, frac_grid_burned_out real(kind_phys), dimension(:), intent(inout) :: max_fplume, min_fplume, uspdavg, hpbl_thetav real(kind_phys), dimension(:), intent(inout) :: hwp, peak_hr_out real(kind_phys), dimension(:), intent(inout) :: hwp_ave @@ -816,13 +815,8 @@ subroutine rrfs_smoke_prep( & vvel(i,k,j)=-w(i,kkp)*rri(i,k,j)/g moist(i,k,j,:)=0. moist(i,k,j,1)=gq0(i,kkp,1) - !if (t_phy(i,k,j) > 265.) then - moist(i,k,j,2)=gq0(i,kkp,2) - if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. - !else - ! moist(i,k,j,2)=0. - if(moist(i,k,j,3) < 1.e-8)moist(i,k,j,3)=0. - !endif + moist(i,k,j,2)=gq0(i,kkp,2) + if (moist(i,k,j,2) < 1.e-8) moist(i,k,j,2)=0. !-- zmid(i,k,j)=phl3d(i,kkp)/g enddo diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index fc3aa9fe6..e00781ec1 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -731,9 +731,9 @@ kind = kind_phys intent = inout [fire_type_out] - standard_name = fire_type_out + standard_name = fire_type long_name = type of fire - units = none + units = 1 dimensions = (horizontal_loop_extent) type = integer intent = out @@ -791,17 +791,17 @@ type = integer intent = in [uspdavg] - standard_name = bl_averaged_wind_speed + standard_name = mean_wind_speed_in_boundary_layer long_name = average wind speed within the boundary layer - units = none + units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = inout [hpbl_thetav] - standard_name = pbl_height_thetav + standard_name = atmosphere_boundary_layer_thickness_from_modified_parcel long_name = pbl height based on modified parcel method - units = none + units = m dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -861,24 +861,16 @@ type = real kind = kind_phys intent = inout -[fire_in] - standard_name = smoke_fire_auxiliary_input - long_name = smoke fire auxiliary input variables - units = various - dimensions = (horizontal_loop_extent,fire_auxiliary_data_extent) - type = real - kind = kind_phys - intent = inout [peak_hr_out] standard_name = peak_hr_fire - long_name = hour of peak fire emissions - units = none + long_name = time_of_peak_fire_emissions + units = s dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = out [lu_nofire_out] - standard_name = lu_nofire_out + standard_name = sum_of_land_use_fractions_for_no_fire_pixels long_name = land use of no fire pixels for type units = frac dimensions = (horizontal_loop_extent) @@ -886,7 +878,7 @@ kind = kind_phys intent = out [lu_qfire_out] - standard_name = lu_qfire_out + standard_name = sum_of_land_use_fractions_for_cropland_fire_pixels long_name = land use of fire pixels for type units = frac dimensions = (horizontal_loop_extent) From a0acaedeb7512f9c3cc062922b83466ffdfc2478 Mon Sep 17 00:00:00 2001 From: "Haiqin.Li" Date: Wed, 24 Jan 2024 16:35:59 +0000 Subject: [PATCH 60/64] "update to resolve code managers' comments" --- physics/smoke_dust/module_add_emiss_burn.F90 | 6 +++--- physics/smoke_dust/rrfs_smoke_wrapper.meta | 4 ++-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/physics/smoke_dust/module_add_emiss_burn.F90 b/physics/smoke_dust/module_add_emiss_burn.F90 index f1bbaeee9..80d91bb0e 100755 --- a/physics/smoke_dust/module_add_emiss_burn.F90 +++ b/physics/smoke_dust/module_add_emiss_burn.F90 @@ -89,8 +89,7 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & if (ebb_dcycle==2) then ! Constants for the fire diurnal cycle calculation - coef_con = 1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys * sigma_fire_dur(1) *fire_age) * & - exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) + coef_con=1._kind_phys/((2._kind_phys*pi)**0.5_kind_phys) do j=jts,jte do i=its,ite fire_age= time_int + (fire_end_hr(i,j)-1._kind_phys)*3600._kind_phys !One hour delay is due to the latency of the RAVE files @@ -99,7 +98,8 @@ subroutine add_emis_burn(dtstep,dz8w,rho_phy,pi, & SELECT CASE ( fire_type(i,j) ) !Ag, urban fires, bare land etc. CASE (1) ! these fires will have exponentially decreasing diurnal cycle, - coef_bb_dc(i,j) = coef_con + coef_bb_dc(i,j) = coef_con*1._kind_phys/(sigma_fire_dur(1) *fire_age) * & + exp(- ( log(fire_age) - avg_fire_dur(1))**2 /(2._kind_phys*sigma_fire_dur(1)**2 )) IF ( dbg_opt .AND. time_int<5000.) then WRITE(6,*) 'i,j,peak_hr(i,j) ',i,j,peak_hr(i,j) diff --git a/physics/smoke_dust/rrfs_smoke_wrapper.meta b/physics/smoke_dust/rrfs_smoke_wrapper.meta index e00781ec1..271d2dd36 100755 --- a/physics/smoke_dust/rrfs_smoke_wrapper.meta +++ b/physics/smoke_dust/rrfs_smoke_wrapper.meta @@ -872,7 +872,7 @@ [lu_nofire_out] standard_name = sum_of_land_use_fractions_for_no_fire_pixels long_name = land use of no fire pixels for type - units = frac + units = 1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys @@ -880,7 +880,7 @@ [lu_qfire_out] standard_name = sum_of_land_use_fractions_for_cropland_fire_pixels long_name = land use of fire pixels for type - units = frac + units = 1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys From 5fe0d63eee3eb05bb5e37b5e136229ac3d84cf98 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Thu, 25 Jan 2024 13:33:36 +0000 Subject: [PATCH 61/64] Change flag_for_air_sea_flux_computation_over_water to control_for_air_sea_flux_computation_over_water. --- physics/PBL/SATMEDMF/satmedmfvdifq.meta | 4 ++-- physics/SFC_Layer/UFS/sfc_diag.meta | 4 ++-- physics/SFC_Layer/UFS/sfc_diff.meta | 4 ++-- physics/SFC_Layer/UFS/sfc_nst.meta | 4 ++-- physics/SFC_Models/Ocean/UFS/sfc_ocean.meta | 4 ++-- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.meta b/physics/PBL/SATMEDMF/satmedmfvdifq.meta index ec80ba422..ff570dce0 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.meta @@ -234,9 +234,9 @@ kind = kind_phys intent = in [icplocn2atm] - standard_name = flag_for_air_sea_flux_computation_over_water + standard_name = control_for_air_sea_flux_computation_over_water long_name = air-sea flux option - units = flag + units = 1 dimensions = () type = integer intent = in diff --git a/physics/SFC_Layer/UFS/sfc_diag.meta b/physics/SFC_Layer/UFS/sfc_diag.meta index b432d75b7..f5e0ab89e 100644 --- a/physics/SFC_Layer/UFS/sfc_diag.meta +++ b/physics/SFC_Layer/UFS/sfc_diag.meta @@ -141,9 +141,9 @@ kind = kind_phys intent = in [icplocn2atm] - standard_name = flag_for_air_sea_flux_computation_over_water + standard_name = control_for_air_sea_flux_computation_over_water long_name = air-sea flux option - units = flag + units = 1 dimensions = () type = integer intent = in diff --git a/physics/SFC_Layer/UFS/sfc_diff.meta b/physics/SFC_Layer/UFS/sfc_diff.meta index eae4c58b0..f2bee7d2c 100644 --- a/physics/SFC_Layer/UFS/sfc_diff.meta +++ b/physics/SFC_Layer/UFS/sfc_diff.meta @@ -258,9 +258,9 @@ type = integer intent = in [icplocn2atm] - standard_name = flag_for_air_sea_flux_computation_over_water + standard_name = control_for_air_sea_flux_computation_over_water long_name = air-sea flux option - units = flag + units = 1 dimensions = () type = integer intent = in diff --git a/physics/SFC_Layer/UFS/sfc_nst.meta b/physics/SFC_Layer/UFS/sfc_nst.meta index ba075e5ae..2181f0bf4 100644 --- a/physics/SFC_Layer/UFS/sfc_nst.meta +++ b/physics/SFC_Layer/UFS/sfc_nst.meta @@ -151,9 +151,9 @@ kind = kind_phys intent = in [icplocn2atm] - standard_name = flag_for_air_sea_flux_computation_over_water + standard_name = control_for_air_sea_flux_computation_over_water long_name = air-sea flux option - units = flag + units = 1 dimensions = () type = integer intent = in diff --git a/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta index c380a7540..4672a6dc4 100644 --- a/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta +++ b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta @@ -103,9 +103,9 @@ kind = kind_phys intent = in [icplocn2atm] - standard_name = flag_for_air_sea_flux_computation_over_water + standard_name = control_for_air_sea_flux_computation_over_water long_name = air-sea flux option - units = flag + units = 1 dimensions = () type = integer intent = in From 4bdf3fab29da51e487143e8b5e3ce8ed5d599127 Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Thu, 25 Jan 2024 14:49:22 +0000 Subject: [PATCH 62/64] add kind_phys to parameter in mp_nssl --- physics/MP/NSSL/mp_nssl.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/MP/NSSL/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 index ad1d41090..e250527c4 100644 --- a/physics/MP/NSSL/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -79,7 +79,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k real :: nssl_params(20) integer :: ihailv,ipc - real, parameter :: qmin = 1.e-12 + real(kind_phys), parameter :: qmin = 1.e-12 integer :: ierr logical :: missing_vars = .False. @@ -347,7 +347,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & its,ite, jts,jte, kts,kte, i,j,k integer :: itimestep ! timestep counter integer :: ntmul, n - real, parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) + real(kind_phys), parameter :: dtpmax = 60. ! allow up to dt=75 (1.25*60) real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical :: invertccn From be9b2b726d5ab08a7630def5b7559d55fa6dcd1f Mon Sep 17 00:00:00 2001 From: Jili Dong Date: Thu, 25 Jan 2024 14:54:44 +0000 Subject: [PATCH 63/64] add more kind_phys to real variables in mp_nssl --- physics/MP/NSSL/mp_nssl.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/physics/MP/NSSL/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 index e250527c4..0b111f7cd 100644 --- a/physics/MP/NSSL/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -77,7 +77,7 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! Local variables: dimensions used in nssl_init integer :: ims,ime, jms,jme, kms,kme, nx, nz, i,k - real :: nssl_params(20) + real(kind_phys) :: nssl_params(20) integer :: ihailv,ipc real(kind_phys), parameter :: qmin = 1.e-12 integer :: ierr @@ -351,7 +351,7 @@ subroutine mp_nssl_run(ncol, nlev, con_g, con_rd, mpirank, & real(kind_phys) :: dtptmp integer, parameter :: ndebug = 0 logical :: invertccn - real :: cwmas + real(kind_phys) :: cwmas real(kind_phys), allocatable :: an(:,:,:,:) ! temporary scalar array From 51204101eeb68dcbed08d13cc0a341a25ee1a229 Mon Sep 17 00:00:00 2001 From: "Bin.Li" Date: Fri, 26 Jan 2024 09:27:17 +0000 Subject: [PATCH 64/64] Update standard_name and long_name for usfco and vsfco. --- physics/PBL/SATMEDMF/satmedmfvdifq.meta | 8 ++++---- physics/SFC_Layer/UFS/sfc_diag.meta | 8 ++++---- physics/SFC_Layer/UFS/sfc_diff.meta | 8 ++++---- physics/SFC_Layer/UFS/sfc_nst.meta | 8 ++++---- physics/SFC_Models/Ocean/UFS/sfc_ocean.meta | 8 ++++---- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.meta b/physics/PBL/SATMEDMF/satmedmfvdifq.meta index ff570dce0..e203187aa 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.meta @@ -218,16 +218,16 @@ kind = kind_phys intent = in [usfco] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal + standard_name = x_ocean_current + long_name = zonal current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [vsfco] - standard_name = ocn_current_merid - long_name = ocn_current_merid + standard_name = y_ocean_current + long_name = meridional current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/SFC_Layer/UFS/sfc_diag.meta b/physics/SFC_Layer/UFS/sfc_diag.meta index f5e0ab89e..4fdf37916 100644 --- a/physics/SFC_Layer/UFS/sfc_diag.meta +++ b/physics/SFC_Layer/UFS/sfc_diag.meta @@ -125,16 +125,16 @@ kind = kind_phys intent = in [usfco] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal + standard_name = x_ocean_current + long_name = zonal current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [vsfco] - standard_name = ocn_current_merid - long_name = ocn_current_merid + standard_name = y_ocean_current + long_name = meridional current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/SFC_Layer/UFS/sfc_diff.meta b/physics/SFC_Layer/UFS/sfc_diff.meta index f2bee7d2c..0964473cb 100644 --- a/physics/SFC_Layer/UFS/sfc_diff.meta +++ b/physics/SFC_Layer/UFS/sfc_diff.meta @@ -235,16 +235,16 @@ kind = kind_phys intent = in [usfco] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal + standard_name = x_ocean_current + long_name = zonal current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [vsfco] - standard_name = ocn_current_merid - long_name = ocn_current_merid + standard_name = y_ocean_current + long_name = meridional current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/SFC_Layer/UFS/sfc_nst.meta b/physics/SFC_Layer/UFS/sfc_nst.meta index 2181f0bf4..80f468803 100644 --- a/physics/SFC_Layer/UFS/sfc_nst.meta +++ b/physics/SFC_Layer/UFS/sfc_nst.meta @@ -135,16 +135,16 @@ kind = kind_phys intent = in [usfco] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal + standard_name = x_ocean_current + long_name = zonal current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [vsfco] - standard_name = ocn_current_merid - long_name = ocn_current_merid + standard_name = y_ocean_current + long_name = meridional current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta index 4672a6dc4..15d9fb5c4 100644 --- a/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta +++ b/physics/SFC_Models/Ocean/UFS/sfc_ocean.meta @@ -87,16 +87,16 @@ kind = kind_phys intent = in [usfco] - standard_name = ocn_current_zonal - long_name = ocn_current_zonal + standard_name = x_ocean_current + long_name = zonal current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real kind = kind_phys intent = in [vsfco] - standard_name = ocn_current_merid - long_name = ocn_current_merid + standard_name = y_ocean_current + long_name = meridional current at ocean surface units = m s-1 dimensions = (horizontal_loop_extent) type = real