From 872b60e423a62e9d4184432d6a80aed62e775feb Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Wed, 3 May 2023 16:39:38 -0600 Subject: [PATCH 01/75] build script mods to allow se builds --- bld/configure | 4 ++-- bld/namelist_files/namelist_defaults_cam.xml | 2 +- cime_config/config_component.xml | 2 +- cime_config/config_compsets.xml | 2 +- cime_config/usermods_dirs/scam_mandatory/shell_commands | 3 --- 5 files changed, 5 insertions(+), 8 deletions(-) diff --git a/bld/configure b/bld/configure index 3bb8f8958b..9b9e1c83b2 100755 --- a/bld/configure +++ b/bld/configure @@ -1178,7 +1178,7 @@ if (defined $opts{'scam'}) { my $scam = $cfg_ref->get('scam') ? "ON" : "OFF"; # The only dycore supported in SCAM mode is Eulerian -if ($scam eq 'ON' and $dyn_pkg ne 'eul') { +if ($scam eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) { die <<"EOF"; ** ERROR: SCAM mode only works with Eulerian dycore. ** Requested dycore is: $dyn_pkg @@ -1195,7 +1195,7 @@ if (defined $opts{'camiop'}) { my $camiop = $cfg_ref->get('camiop') ? "ON" : "OFF"; # The only dycore supported in CAMIOP mode is Eulerian -if ($camiop eq 'ON' and $dyn_pkg ne 'eul') { +if ($camiop eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) { die <<"EOF"; ** ERROR: CAMIOP mode only works with Eulerian dycore. ** Requested dycore is: $dyn_pkg diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 3444771dae..cbcdf60b6d 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2799,7 +2799,7 @@ -atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc +atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc atm/cam/scam/iop/ARM97_4scam.nc 1500 9 diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 897e69b3b8..41dc06a0f0 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -135,7 +135,7 @@ -chem trop_strat_mam5_vbsext -chem trop_strat_mam5_ts2 -clubb_sgs - -dyn eul -scam + -scam -rad camrt -chem none -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_sam1mom -rad camrt -chem none -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_sam1mom -spcam_clubb_sgs -rad rrtmg -chem trop_mam3 -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_m2005 diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index a474d0c313..61490aca16 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -113,7 +113,7 @@ FSCAM 2000_CAM60%SCAM_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - + diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index 0772ae5f3c..ac3cfb1198 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -2,9 +2,6 @@ # these are necessary for scam runs. #======================================== # -# SCAM works in SPMD mode with a single task, but the default is to run serially. -./xmlchange MPILIB=mpi-serial - # SCAM doesn't have restart functionality yet. ./xmlchange REST_OPTION=never From 3006e9c1a65d0a12f74f07184beddb935a431d8e Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Wed, 20 Sep 2023 11:08:14 -0600 Subject: [PATCH 02/75] se scam update --- bld/build-namelist | 3 +- bld/namelist_files/namelist_defaults_cam.xml | 14 +- bld/namelist_files/namelist_definition.xml | 6 + .../scam_mandatory/shell_commands | 6 +- .../eul => control}/getinterpnetcdfdata.F90 | 27 +- src/control/history_defaults.F90 | 60 +- src/control/history_scam.F90 | 70 +- src/control/ncdio_atm.F90 | 204 +- src/control/scamMod.F90 | 1487 ++++- src/cpl/nuopc/atm_comp_nuopc.F90 | 4 + src/cpl/nuopc/atm_stream_ndep.F90 | 25 + src/dynamics/eul/iop.F90 | 1052 +-- src/dynamics/se/apply_iop_forcing.F90 | 175 + src/dynamics/se/dp_coupling.F90 | 8 +- src/dynamics/se/dycore/prim_advance_mod.F90 | 2 + src/dynamics/se/dycore/prim_driver_mod.F90 | 187 +- src/dynamics/se/dyn_comp.F90 | 240 +- src/dynamics/se/se_single_column_mod.F90 | 337 + src/dynamics/se/stepon.F90 | 133 +- src/infrastructure/phys_grid.F90 | 146 +- src/physics/cam/cam_diagnostics.F90 | 2 + src/physics/cam/check_energy.F90 | 28 +- src/physics/cam/chem_surfvals.F90 | 10 +- src/physics/cam/clubb_intr.F90 | 14 +- src/physics/cam/phys_grid.F90 | 5740 +++-------------- src/physics/cam/physpkg.F90 | 2457 ++++--- src/utils/cam_grid_support.F90 | 2 +- 27 files changed, 5105 insertions(+), 7334 deletions(-) rename src/{dynamics/eul => control}/getinterpnetcdfdata.F90 (90%) create mode 100644 src/dynamics/se/apply_iop_forcing.F90 create mode 100644 src/dynamics/se/se_single_column_mod.F90 diff --git a/bld/build-namelist b/bld/build-namelist index 2cec1b4a51..361ab6f8dc 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -2412,7 +2412,8 @@ if (($chem =~ /_mam4/ or $chem =~ /_mam5/) and ($phys =~ /cam6/ or $phys =~ /cam } # MEGAN emissions - if (($chem eq 'trop_mam4' or $chem eq 'waccm_sc_mam4' or $chem eq 'ghg_mam4') and !$aqua_mode and !$scam){ +#jt if (($chem eq 'trop_mam4' or $chem eq 'waccm_sc_mam4' or $chem eq 'ghg_mam4') and !$aqua_mode and !$scam){ + if (($chem eq 'trop_mam4' or $chem eq 'waccm_sc_mam4' or $chem eq 'ghg_mam4') and !$aqua_mode){ my $val = "'SOAE = 0.9058*isoprene + 5.8638*(carene_3 + pinene_a + thujene_a + bornene +'," . "' terpineol_4 + terpineol_a + terpinyl_ACT_a + myrtenal + sabinene + pinene_b + camphene +'," . "' fenchene_a + limonene + phellandrene_a + terpinene_a + terpinene_g + terpinolene +'," diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index cbcdf60b6d..04eb5fdaf7 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -213,8 +213,12 @@ atm/cam/inic/gaus/cami_0000-09-01_8x16_L26_c030918.nc atm/cam/inic/gaus/cami_0000-01-01_8x16_L30_c090102.nc - +atm/cam/inic/se/cam6_3_082_QPC6_ne3pg3_ne3pg3_mg37_L32_nuopc_36pes_221214_topotest.cam.i.0001-01-31-00000.nc +atm/cam/inic/se/cam6_3_082_QPC6_ne3pg3_ne3pg3_mg37_L58_nuopc_36pes_221214_topotest.cam.i.0001-01-31-00000.nc +atm/cam/inic/se/cam6_3_082_QPC6_ne3pg3_ne3pg3_mg37_L93_nuopc_36pes_221214_topotest.cam.i.0001-01-31-00000.nc atm/cam/inic/homme/cami-mam3_0000-01_ne5np4_L30.140707.nc +atm/cam/inic/se/F2000climo_ne5pg3_ne5pg3_mg37_L32_nuopc_144pes_230520.cam.i.0001-01-31-00000.nc +atm/cam/inic/se/F2000climo_ne5pg3_ne5pg3_mg37_L58_nuopc_144pes_230520.cam.i.0001-01-31-00000.nc atm/cam/inic/se/ape_topo_cam4_ne16np4_L26_c171020.nc atm/cam/inic/se/ape_topo_cam4_ne16np4_L30_c171020.nc atm/cam/inic/se/ape_topo_cam4_ne16np4_L32_c171020.nc @@ -244,6 +248,8 @@ atm/cam/inic/se/ape_cam5_ne30np4_L30_c170417.nc atm/cam/inic/se/ape_cam5_ne120np4_L30_c170419.nc +atm/cam/inic/se/cam6_3_082_QPC6_ne3pg3_ne3pg3_mg37_L32_nuopc_36pes_221214_test.cam.i.0001-01-31-00000.nc +atm/cam/inic/se/cam6_3_082_QPC6_ne3pg3_ne3pg3_mg37_L58_nuopc_36pes_221214_test.cam.i.0001-01-31-00000.nc atm/cam/inic/se/ape_cam6_ne5np4_L32_c170517.nc atm/cam/inic/se/ape_cam6_ne16np4_L32_c170509.nc atm/cam/inic/se/ape_cam6_ne30np4_L32_c170509.nc @@ -303,6 +309,8 @@ atm/cam/topo/se/ne120pg2_nc3000_Co015_Fi001_PF_nullRR_Nsw010_20171012.nc atm/cam/topo/se/ne240pg2_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171014.nc +atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc +atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_20230105.nc @@ -1851,8 +1859,12 @@ OFF +atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc +atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_221214.nc atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc +atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc +atm/cam/chem/trop_mam/atmsrf_ne16pg3_230520.nc atm/cam/chem/trop_mam/atmsrf_ne30np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne30np4.pg2_200108.nc atm/cam/chem/trop_mam/atmsrf_ne30pg3_180522.nc diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 14b0dcfc8c..495de4b2f3 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -5612,6 +5612,12 @@ Use the SCAM-IOP specified observed water vapor at each time step instead of for Default: FALSE + +Use the SCAM-IOP 3d forcing if true, use combination of dycore vertical advection and iop horiz advection if false +Default: + + Force scam to use the lat lon fields specified in the scam namelist not what is closest to IOP avail lat lon diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index ac3cfb1198..87963c132f 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -7,6 +7,6 @@ # Note that clm cannot use initial conditions with SCAM -so will only use specified phenology # Only change if CLM_FORCE_COLDSTART exists. -if [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then -./xmlchange CLM_FORCE_COLDSTART='on' -fi +#if [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then +#./xmlchange CLM_FORCE_COLDSTART='on' +#fi diff --git a/src/dynamics/eul/getinterpnetcdfdata.F90 b/src/control/getinterpnetcdfdata.F90 similarity index 90% rename from src/dynamics/eul/getinterpnetcdfdata.F90 rename to src/control/getinterpnetcdfdata.F90 index a86ae52621..15fa0e6798 100644 --- a/src/dynamics/eul/getinterpnetcdfdata.F90 +++ b/src/control/getinterpnetcdfdata.F90 @@ -9,7 +9,6 @@ module getinterpnetcdfdata ! use cam_abortutils, only: endrun use pmgrid, only: plev - use scamMod, only: scm_crm_mode use cam_logfile, only: iulog implicit none @@ -22,8 +21,8 @@ module getinterpnetcdfdata contains subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & - varName, have_surfdat, surfdat, fill_ends, & - press, npress, ps, outData, STATUS ) + varName, have_surfdat, surfdat, fill_ends, scm_crm_mode, & + press, npress, ps, hyam, hybm, outData, STATUS ) ! getinterpncdata: extracts the entire level dimension for a ! particular lat,lon,time from a netCDF file @@ -43,10 +42,13 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & integer, intent(in) :: TimeIdx ! time index real(r8), intent(in) :: camlat,camlon ! target lat and lon to be extracted logical, intent(in) :: have_surfdat ! is surfdat provided - logical, intent(in) :: fill_ends ! extrapolate the end values + logical, intent(in) :: fill_ends ! extrapolate the end values + logical, intent(in) :: scm_crm_mode ! extrapolate the end values integer, intent(in) :: npress ! number of dataset pressure levels real(r8), intent(in) :: press(npress) ! dataset pressure levels - real(r8), intent(in) :: ps ! dataset pressure levels + real(r8), intent(in) :: ps ! dataset pressure levels + real(r8), intent(in) :: hyam(:) ! dataset hybrid midpoint pressure levels + real(r8), intent(in) :: hybm(:) ! dataset hybrid midpoint pressure levels ! ---------- outputs ---------- @@ -132,7 +134,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & usable_var = .true. endif - if ( dim_name .EQ. 'lon' ) then + if ( dim_name .EQ. 'lon' .or. dim_name .EQ. 'ncol' .or. dim_name .EQ. 'ncol_d' ) then start( i ) = lonIdx count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 @@ -236,7 +238,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & enddo #endif ! - call interplevs( tmp(:npress), press, npress, ps, fill_ends,outdata ) + call interplevs( tmp(:npress), press, npress, ps, fill_ends, hyam, hybm, outdata ) endif @@ -245,10 +247,9 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & end subroutine getinterpncdata subroutine interplevs( inputdata, dplevs, nlev, & - ps, fill_ends, outdata) + ps, fill_ends, hyam, hybm, outdata) use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8 - use hycoef, only: hyam, hybm use interpolate_data, only: lininterp implicit none @@ -264,12 +265,14 @@ subroutine interplevs( inputdata, dplevs, nlev, & ! ------- inputs ----------- integer, intent(in) :: nlev ! num press levels in dataset - real(r8), intent(in) :: ps ! surface pressure + real(r8), intent(in) :: ps ! surface pressure + real(r8), intent(in) :: hyam(:) ! a midpoint pressure + real(r8), intent(in) :: hybm(:) ! b midpoint pressure real(r8), intent(in) :: inputdata(nlev) ! data from netcdf dataset - real(r8), intent(in) :: dplevs(nlev) ! input data pressure levels + real(r8), intent(in) :: dplevs(nlev) ! input data pressure levels logical, intent(in) :: fill_ends ! fill in missing end values(used for - ! global model datasets) + ! global model datasets) ! ------- outputs ---------- diff --git a/src/control/history_defaults.F90 b/src/control/history_defaults.F90 index 73e5554e14..0975f56a91 100644 --- a/src/control/history_defaults.F90 +++ b/src/control/history_defaults.F90 @@ -45,19 +45,23 @@ subroutine bldfld () ! Local workspace ! integer m ! Index + character(len=100) dyngrid + + ! Currently SE is the only supported dycore for REPLAY + dyngrid = 'GLL' !jt !jt Maybe add this to scam specific initialization !jt #if ( defined BFB_CAM_SCAM_IOP ) - call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname='gauss_grid') + call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=dyngrid) call add_default ('CLAT1&IC',0,'I') - call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname='gauss_grid') + call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname=dyngrid) call add_default ('CLON1&IC',0,'I') - call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname='gauss_grid') + call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname=dyngrid) call add_default ('PHI&IC',0, 'I') - call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname='gauss_grid') + call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname=dyngrid) call add_default ('LAM&IC',0, 'I') #endif @@ -72,7 +76,7 @@ subroutine initialize_iop_history() ! ! !DESCRIPTION: ! !USES: - use iop +!jt use iop use phys_control, only: phys_getopts ! !ARGUMENTS: implicit none @@ -85,41 +89,49 @@ subroutine initialize_iop_history() ! ! !LOCAL VARIABLES: integer m -!----------------------------------------------------------------------- - call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname='gauss_grid') + character(len=100) dyngrid + + ! Currently SE is the only supported dycore for REPLAY + dyngrid = 'GLL' +!jt dyngrid = 'gauss_grid' + !----------------------------------------------------------------------- + call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname=trim(dyngrid)) call add_default ('CLAT',2,' ') - call addfld ('q', (/ 'lev' /), 'A', 'kg/kg', 'Q for scam',gridname='gauss_grid') + call addfld ('q', (/ 'lev' /), 'A', 'kg/kg', 'Q for scam',gridname=trim(dyngrid)) call add_default ('q',2, ' ') - call addfld ('u', (/ 'lev' /), 'A', 'm/s', 'U for scam',gridname='gauss_grid') + call addfld ('u', (/ 'lev' /), 'A', 'm/s', 'U for scam',gridname=trim(dyngrid)) call add_default ('u',2,' ') - call addfld ('v', (/ 'lev' /), 'A', 'm/s', 'V for scam',gridname='gauss_grid') + call addfld ('v', (/ 'lev' /), 'A', 'm/s', 'V for scam',gridname=trim(dyngrid)) call add_default ('v',2,' ') - call addfld ('t', (/ 'lev' /), 'A', 'K', 'Temperature for scam',gridname='gauss_grid') + call addfld ('t', (/ 'lev' /), 'A', 'K', 'Temperature for scam',gridname=trim(dyngrid)) call add_default ('t',2,' ') call addfld ('Tg', horiz_only, 'A', 'K', 'Surface temperature (radiative) for scam',gridname='physgrid') call add_default ('Tg',2,' ') - call addfld ('Ps', horiz_only, 'A', 'Pa', 'Ps for scam',gridname='gauss_grid') + call addfld ('Ps', horiz_only, 'A', 'Pa', 'Ps for scam',gridname=trim(dyngrid)) call add_default ('Ps',2,' ') - call addfld ('divT3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for T',gridname='gauss_grid') + call addfld ('divT3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for T',gridname=trim(dyngrid)) call add_default ('divT3d',2,' ') - call addfld ('divU3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for U',gridname='gauss_grid') + call addfld ('divU3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for U',gridname=trim(dyngrid)) call add_default ('divU3d',2,' ') - call addfld ('divV3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for V',gridname='gauss_grid') + call addfld ('divV3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for V',gridname=trim(dyngrid)) call add_default ('divV3d',2,' ') - call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname='gauss_grid') + call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) call add_default ('fixmas',2,' ') - call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname='gauss_grid') + call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) call add_default ('beta',2,' ') + call addfld ('heat_glob',horiz_only, 'A', 'K/s', 'Global mean total energy difference') + call add_default ('heat_glob',2,' ') + do m=1,pcnst call addfld (trim(cnst_name(m))//'_dten', (/ 'lev' /), 'A', 'kg/kg', & - trim(cnst_name(m))//' IOP Dynamics Residual for '//trim(cnst_name(m)),gridname='gauss_grid') + trim(cnst_name(m))//' IOP Dynamics Residual for '//trim(cnst_name(m)),gridname=trim(dyngrid)) call add_default (trim(cnst_name(m))//'_dten',2,' ') - call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & - gridname='gauss_grid') - call add_default (trim(cnst_name(m))//'_alph',2,' ') - call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & - gridname='gauss_grid') - call add_default (trim(cnst_name(m))//'_dqfx',2,' ') +!!$ call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & +!!$ gridname=trim(dyngrid)) +!!$ call add_default (trim(cnst_name(m))//'_alph',2,' ') +!!$ call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & +!!$ gridname=trim(dyngrid)) +!!$ call add_default (trim(cnst_name(m))//'_dqfx',2,' ') end do call addfld ('shflx', horiz_only, 'A', 'W/m2', 'Surface sensible heat flux for scam',gridname='physgrid') call add_default ('shflx',2,' ') diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index 2c81ce1a78..af40cdba9a 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -41,64 +41,64 @@ subroutine scm_intht() ! ! Call addfld to add each field to the Master Field List. ! - call addfld ('TDIFF', (/ 'lev' /), 'A', 'K','difference from observed temp', gridname='gauss_grid') - call addfld ('UDIFF', (/ 'lev' /), 'A', 'K','difference from observed u wind', gridname='gauss_grid') - call addfld ('VDIFF', (/ 'lev' /), 'A', 'K','difference from observed v wind', gridname='gauss_grid') + call addfld ('TDIFF', (/ 'lev' /), 'A', 'K','difference from observed temp', gridname='physgrid') + call addfld ('UDIFF', (/ 'lev' /), 'A', 'K','difference from observed u wind', gridname='physgrid') + call addfld ('VDIFF', (/ 'lev' /), 'A', 'K','difference from observed v wind', gridname='physgrid') call addfld ('TOBS', (/ 'lev' /), 'A', 'K','observed temp') - call addfld ('QDIFF', (/ 'lev' /), 'A', 'kg/kg','difference from observed water', gridname='gauss_grid') + call addfld ('QDIFF', (/ 'lev' /), 'A', 'kg/kg','difference from observed water', gridname='physgrid') call addfld ('QOBS', (/ 'lev' /), 'A', 'kg/kg','observed water', gridname='physgrid') call addfld ('PRECOBS', (/ 'lev' /), 'A', 'mm/day','Total (convective and large-scale) precipitation rate', & gridname='physgrid') call addfld ('DIVQ', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horizontal)', gridname='physgrid') - call addfld ('DIVQ3D', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horiz/vert combined)', gridname='gauss_grid') + call addfld ('DIVQ3D', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horiz/vert combined)', gridname='physgrid') call addfld ('DIVV', (/ 'lev' /), 'A', 'm/s2','V advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVU', (/ 'lev' /), 'A', 'm/s2','U advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVT', (/ 'lev' /), 'A', 'K/s','T advection tendency (horizontal)', gridname='physgrid') - call addfld ('DIVT3D', (/ 'lev' /), 'A', 'K/s','T advection tendency (horiz/vert combined)', gridname='gauss_grid') - call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname='gauss_grid') - call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname='gauss_grid') + call addfld ('DIVT3D', (/ 'lev' /), 'A', 'K/s','T advection tendency (horiz/vert combined)', gridname='physgrid') + call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname='physgrid') + call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname='physgrid') call addfld ('SHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface sensible heat flux', gridname='physgrid') call addfld ('LHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface latent heat flux', gridname='physgrid') - call addfld ('TRELAX', (/ 'lev' /), 'A', 'K','t relaxation amount', gridname='gauss_grid') - call addfld ('QRELAX', (/ 'lev' /), 'A', 'kg/kg','q relaxation amount', gridname='gauss_grid') - call addfld ('TAURELAX', (/ 'lev' /), 'A', 'seconds','relaxation time constant', gridname='gauss_grid') + call addfld ('TRELAX', (/ 'lev' /), 'A', 'K','t relaxation amount', gridname='physgrid') + call addfld ('QRELAX', (/ 'lev' /), 'A', 'kg/kg','q relaxation amount', gridname='physgrid') + call addfld ('TAURELAX', (/ 'lev' /), 'A', 'seconds','relaxation time constant', gridname='physgrid') call add_default ('TDIFF', 1, ' ') call add_default ('QDIFF', 1, ' ') ! Vertical advective forcing of 'T,u,v,qv,ql,qi,nl,ni' in forecast.F90 - call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname='gauss_grid' ) - call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname='gauss_grid' ) + call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname='physgrid' ) + call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname='physgrid' ) + call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname='physgrid' ) + call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname='physgrid' ) + call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname='physgrid' ) + call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname='physgrid' ) + call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname='physgrid' ) + call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname='physgrid' ) ! call addfld ('T3D_ADV_SLT', 'K/s' , pver, 'I', 'T 3d slt advective forcing', gridname='physgrid') ! call addfld ('U3D_ADV_SLT', 'm/s^2' , pver, 'I', 'U 3d slt advective forcing', gridname='physgrid') ! call addfld ('V3D_ADV_SLT', 'm/s^2' , pver, 'I', 'V 3d slt advective forcing', gridname='physgrid') - call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='gauss_grid' ) - call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='gauss_grid' ) - call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname='gauss_grid' ) - call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname='gauss_grid' ) - call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname='gauss_grid' ) + call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='physgrid' ) + call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='physgrid' ) + call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='physgrid' ) + call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname='physgrid' ) + call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname='physgrid' ) + call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname='physgrid' ) + call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname='physgrid' ) + call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname='physgrid' ) - call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='gauss_grid' ) - call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='gauss_grid' ) - call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname='gauss_grid' ) - call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname='gauss_grid' ) - call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname='gauss_grid' ) - call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname='gauss_grid' ) + call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='physgrid' ) + call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='physgrid' ) + call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='physgrid' ) + call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname='physgrid' ) + call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname='physgrid' ) + call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname='physgrid' ) + call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname='physgrid' ) + call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname='physgrid' ) end subroutine scm_intht diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90 index fd57906da4..8ce8f1e998 100644 --- a/src/control/ncdio_atm.F90 +++ b/src/control/ncdio_atm.F90 @@ -20,6 +20,9 @@ module ncdio_atm use scamMod, only: scmlat,scmlon,single_column use cam_logfile, only: iulog use string_utils, only: to_lower + use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id, & + cam_grid_dimensions, cam_grid_get_latvals, cam_grid_get_lonvals, & + max_hcoordname_len ! ! !PUBLIC TYPES: implicit none @@ -68,8 +71,6 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id, & - cam_grid_dimensions use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill ! @@ -112,10 +113,16 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & logical :: readvar_tmp ! if true, variable is on tape character(len=*), parameter :: subname='INFLD_REAL_1D_2D' ! subroutine name + character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid ! For SCAM real(r8) :: closelat, closelon integer :: lonidx, latidx + real(r8), pointer :: latvals_deg(:) + real(r8), pointer :: lonvals_deg(:) + real(r8), allocatable :: pos_lonvals(:) + real (r8) :: pos_scmlon,minpoint,testpoint + integer :: colidx,nvals nullify(iodesc) @@ -128,41 +135,40 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ! Error conditions ! if (present(gridname)) then - grid_id = cam_grid_id(trim(gridname)) + vargridname=trim(gridname) else - grid_id = cam_grid_id('physgrid') + vargridname='physgrid' end if + ! if running single column mode then we need to use scm grid to read proper column + if (single_column .and. trim(vargridname)=='physgrid') then + vargridname='physgrid_scm' + end if + + grid_id = cam_grid_id(trim(vargridname)) + if (.not. cam_grid_check(grid_id)) then if(masterproc) then - if (present(gridname)) then - write(errormsg, *)': invalid gridname, "',trim(gridname),'", specified for field ',trim(varname) - else - write(errormsg, *)': Internal error, no "physgrid" gridname' - end if + write(errormsg, *)': invalid gridname, "',trim(vargridname),'", specified for field ',trim(varname) end if call endrun(trim(subname)//errormsg) end if - ! Get the number of columns in the global grid. - call cam_grid_dimensions(grid_id, grid_dimlens) - if (debug .and. masterproc) then - if (present(gridname)) then - write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(gridname) - else - write(iulog, '(4a)') trim(subname),': field = ',trim(varname),', grid = physgrid' - end if - call shr_sys_flush(iulog) + write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(vargridname) + call shr_sys_flush(iulog) end if + + ! Get the number of columns in the global grid. + call cam_grid_dimensions(grid_id, grid_dimlens) ! - ! Read netCDF file + ! read netcdf file ! ! - ! Check if field is on file; get netCDF variable id + ! check if field is on file; get netcdf variable id ! call cam_pio_check_var(ncid, varname, varid, ndims, dimids, dimlens, readvar_tmp) ! - ! If field is on file: + ! if field is on file: ! if (readvar_tmp) then if (debug .and. masterproc) then @@ -171,13 +177,13 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & call shr_sys_flush(iulog) end if ! - ! Get array dimension id's and sizes + ! get array dimension id's and sizes ! arraydimsize(1) = (dim1e - dim1b + 1) arraydimsize(2) = (dim2e - dim2b + 1) do j = 1, 2 if (arraydimsize(j) /= size(field, j)) then - write(errormsg, *) ': Mismatch between array bounds and field size for ', & + write(errormsg, *) ': mismatch between array bounds and field size for ', & trim(varname), ', dimension', j call endrun(trim(subname)//errormsg) end if @@ -188,14 +194,14 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & else if (ndims < 1) then call endrun(trim(subname)//': too few dimensions for '//trim(varname)) else - ! Check that the number of columns in the file matches the number of + ! check that the number of columns in the file matches the number of ! columns in the grid object. - if (dimlens(1) /= grid_dimlens(1)) then + if (dimlens(1) /= grid_dimlens(1) .and. .not. single_column) then readvar = .false. return end if - ! Check to make sure that the second dimension is time + ! check to make sure that the second dimension is time if (ndims == 2) then ierr = pio_inq_dimname(ncid, dimids(2), tmpname) if (trim(tmpname) /= 'time') then @@ -213,21 +219,15 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ndims = ndims - 1 end if - ! NB: strt and cnt were initialized to 1 - if (single_column) then - !!XXgoldyXX: Clearly, this will not work for an unstructured dycore - call endrun(trim(subname)//': SCAM not supported in this configuration') - else - ! All distributed array processing - call cam_grid_get_decomp(grid_id, arraydimsize, dimlens(1:ndims), & - pio_double, iodesc) - call pio_read_darray(ncid, varid, iodesc, field, ierr) - if (present(fillvalue)) then - ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) - end if - end if - - + ! nb: strt and cnt were initialized to 1 + ! all distributed array processing + call cam_grid_get_decomp(grid_id, arraydimsize, dimlens(1:ndims), & + pio_double, iodesc) + call pio_read_darray(ncid, varid, iodesc, field, ierr) + if (present(fillvalue)) then + ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) + end if + if (masterproc) write(iulog,*) subname//': read field '//trim(varname) end if ! end of readvar_tmp @@ -239,25 +239,24 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & end subroutine infld_real_1d_2d !----------------------------------------------------------------------- - !BOP + !bop ! - ! !IROUTINE: infld_real_2d_2d + ! !iroutine: infld_real_2d_2d ! - ! !INTERFACE: + ! !interface: subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & - dim1b, dim1e, dim2b, dim2e, field, readvar, gridname, timelevel, & + dim1b, dim1e, dim2b, dim2e, field, readvar, gridname, timelevel, & fillvalue) ! - ! !DESCRIPTION: - ! Netcdf I/O of initial real field from netCDF file - ! Read a 2-D field (or slice) into a 2-D variable + ! !description: + ! netcdf i/o of initial real field from netcdf file + ! read a 2-d field (or slice) into a 2-d variable ! - ! !USES + ! !uses ! use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id use cam_pio_utils, only: cam_permute_array, calc_permutation use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill @@ -307,6 +306,7 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & logical :: readvar_tmp ! if true, variable is on tape character(len=*), parameter :: subname='INFLD_REAL_2D_2D' ! subroutine name character(len=PIO_MAX_NAME) :: field_dnames(2) + character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid ! For SCAM real(r8) :: closelat, closelon @@ -324,35 +324,30 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & call infld(varname, ncid, dimname1, dim1b, dim1e, dim2b, dim2e, & field, readvar, gridname, timelevel) else - ! ! Error conditions ! if (present(gridname)) then - grid_id = cam_grid_id(trim(gridname)) + vargridname=trim(gridname) else - grid_id = cam_grid_id('physgrid') + vargridname='physgrid' + end if + ! if running single column mode then we need to use scm grid to read proper column + if (single_column .and. trim(vargridname)=='physgrid') then + vargridname='physgrid_scm' end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then - if (present(gridname)) then - write(errormsg, *)': invalid gridname, "',trim(gridname),'", specified for field ',trim(varname) - else - write(errormsg, *)': Internal error, no "physgrid" gridname' - end if + write(errormsg, *)': invalid gridname, "',trim(vargridname),'", specified for field ',trim(varname) end if call endrun(trim(subname)//errormsg) end if - if (debug .and. masterproc) then - if (present(gridname)) then - write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(gridname) - else - write(iulog, '(4a)') trim(subname),': field = ',trim(varname),', grid = physgrid' + if (debug .and. masterproc) then + write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(vargridname) + call shr_sys_flush(iulog) end if - call shr_sys_flush(iulog) - end if - ! ! Read netCDF file ! @@ -486,8 +481,6 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id, & - cam_grid_dimensions use cam_pio_utils, only: cam_permute_array, calc_permutation use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill @@ -541,6 +534,7 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & character(len=128) :: errormsg character(len=PIO_MAX_NAME) :: field_dnames(2) character(len=PIO_MAX_NAME) :: file_dnames(3) + character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid ! For SCAM real(r8) :: closelat, closelon @@ -557,33 +551,29 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & ! Error conditions ! if (present(gridname)) then - grid_id = cam_grid_id(trim(gridname)) + vargridname=trim(gridname) else - grid_id = cam_grid_id('physgrid') + vargridname='physgrid' end if + ! if running single column mode then we need to use scm grid to read proper column + if (single_column .and. trim(vargridname)=='physgrid') then + vargridname='physgrid_scm' + end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then - if (present(gridname)) then - write(errormsg, *)': invalid gridname, "',trim(gridname),'", specified for field ',trim(varname) - else - write(errormsg, *)': Internal error, no "physgrid" gridname' - end if + write(errormsg, *)': invalid gridname, "',trim(vargridname),'", specified for field ',trim(varname) end if call endrun(trim(subname)//errormsg) end if - ! Get the number of columns in the global grid. - call cam_grid_dimensions(grid_id, grid_dimlens) - if (debug .and. masterproc) then - if (present(gridname)) then - write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(gridname) - else - write(iulog, '(4a)') trim(subname),': field = ',trim(varname),', grid = physgrid' - end if + write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(vargridname) call shr_sys_flush(iulog) end if + ! Get the number of columns in the global grid. + call cam_grid_dimensions(grid_id, grid_dimlens) ! ! Read netCDF file ! @@ -623,7 +613,7 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & else ! Check that the number of columns in the file matches the number of ! columns in the grid object. - if (dimlens(1) /= grid_dimlens(1) .and. dimlens(2) /= grid_dimlens(1)) then + if (dimlens(1) /= grid_dimlens(1) .and. dimlens(2) /= grid_dimlens(1) .and. .not. single_column) then readvar = .false. return end if @@ -649,20 +639,13 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & field_dnames(1) = dimname1 field_dnames(2) = dimname2 ! NB: strt and cnt were initialized to 1 - if (single_column) then - !!XXgoldyXX: Clearly, this will not work for an unstructured dycore - ! Check for permuted dimensions ('out of order' array) -! call calc_permutation(dimids(1:2), arraydimids, permutation, ispermuted) - call endrun(trim(subname)//': SCAM not supported in this configuration') - else - ! All distributed array processing - call cam_grid_get_decomp(grid_id, arraydimsize, dimlens(1:2), & - pio_double, iodesc, field_dnames=field_dnames, & - file_dnames=file_dnames(1:2)) - call pio_read_darray(ncid, varid, iodesc, field, ierr) - if (present(fillvalue)) then - ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) - end if + ! All distributed array processing + call cam_grid_get_decomp(grid_id, arraydimsize, dimlens(1:2), & + pio_double, iodesc, field_dnames=field_dnames, & + file_dnames=file_dnames(1:2)) + call pio_read_darray(ncid, varid, iodesc, field, ierr) + if (present(fillvalue)) then + ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) end if if (masterproc) write(iulog,*) subname//': read field '//trim(varname) @@ -694,7 +677,6 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, & use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname - use cam_grid_support, only: cam_grid_check, cam_grid_get_decomp, cam_grid_id use cam_pio_utils, only: cam_permute_array, calc_permutation use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill @@ -749,6 +731,7 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, & character(len=128) :: errormsg character(len=PIO_MAX_NAME) :: field_dnames(3) character(len=PIO_MAX_NAME) :: file_dnames(4) + character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid ! For SCAM real(r8) :: closelat, closelon @@ -771,35 +754,30 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, & dim1b, dim1e, dim2b, dim2e, dim3b, dim3e, & field, readvar, gridname, timelevel) else - ! ! Error conditions ! if (present(gridname)) then - grid_id = cam_grid_id(trim(gridname)) + vargridname=trim(gridname) else - grid_id = cam_grid_id('physgrid') + vargridname='physgrid' end if + ! if running single column mode then we need to use scm grid to read proper column + if (single_column .and. trim(vargridname)=='physgrid') then + vargridname='physgrid_scm' + end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then - if (present(gridname)) then - write(errormsg, *)': invalid gridname, "',trim(gridname),'", specified for field ',trim(varname) - else - write(errormsg, *)': Internal error, no "physgrid" gridname' - end if + write(errormsg, *)': invalid gridname, "',trim(vargridname),'", specified for field ',trim(varname) end if call endrun(trim(subname)//errormsg) end if if (debug .and. masterproc) then - if (present(gridname)) then - write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(gridname) - else - write(iulog, '(4a)') trim(subname),': field = ',trim(varname),', grid = physgrid' - end if + write(iulog, '(5a)') trim(subname),': field = ',trim(varname),', grid = ',trim(vargridname) call shr_sys_flush(iulog) end if - ! ! Read netCDF file ! diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index b18169b340..02b188b2bb 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -1,3 +1,4 @@ + module scamMod !---------------------------------------------------------------------- ! @@ -20,19 +21,32 @@ module scamMod !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 +use spmd_utils, only: masterproc,npes use pmgrid, only: plon, plat, plev, plevp -use constituents, only: pcnst +use constituents, only: readtrace, cnst_get_ind, pcnst, cnst_name +use netcdf, only: NF90_NOERR,NF90_CLOSE,NF90_GET_VAR,NF90_INQUIRE_DIMENSION, & + NF90_INQ_DIMID, NF90_INQ_VARID, NF90_NOWRITE, NF90_OPEN, & + NF90_GET_ATT,NF90_GLOBAL,NF90_INQUIRE_ATTRIBUTE, & + NF90_INQUIRE_VARIABLE, NF90_MAX_VAR_DIMS, nf90_get_var use shr_scam_mod, only: shr_scam_getCloseLatLon use dycore, only: dycore_is use cam_logfile, only: iulog use cam_abortutils, only: endrun +use time_manager, only: get_curr_date, get_curr_calday,& + get_nstep,is_first_step,get_start_date,timemgr_time_inc + implicit none private ! PUBLIC INTERFACES: -public scam_readnl ! read SCAM namelist options +public :: scam_readnl ! read SCAM namelist options +public :: readiopdata ! read iop boundary data +public :: setiopupdate ! find index in iopboundary data for current time +public :: plevs0 ! find index in iopboundary data for current time +public :: scmiop_flbc_inti +public :: setiopupdate_init ! PUBLIC MODULE DATA: @@ -58,6 +72,7 @@ module scamMod integer, public :: error_code ! Error code from netCDF reads integer, public :: initTimeIdx integer, public :: seedval +integer bdate, last_date, last_sec character*(max_path_len), public :: modelfile character*(max_path_len), public :: analysisfile @@ -106,12 +121,14 @@ module scamMod real(r8), public :: numiceobs(plev) ! actual real(r8), public :: precobs(1) ! observed precipitation real(r8), public :: lhflxobs(1) ! observed surface latent heat flux +real(r8), public :: heat_glob_scm(1) ! observed heat total real(r8), public :: shflxobs(1) ! observed surface sensible heat flux real(r8), public :: q1obs(plev) ! observed apparent heat source real(r8), public :: q2obs(plev) ! observed apparent heat sink real(r8), public :: tdiff(plev) ! model minus observed temp real(r8), public :: tground(1) ! ground temperature -real(r8), public :: tobs(plev) ! actual temperature +real(r8), public :: psobs ! observed surface pressure +real(r8), public :: tobs(plev) ! observed temperature real(r8), public :: tsair(1) ! air temperature at the surface real(r8), public :: udiff(plev) ! model minus observed uwind real(r8), public :: uobs(plev) ! actual u wind @@ -124,6 +141,13 @@ module scamMod real(r8), public :: asdirobs(1) ! observed asdir real(r8), public :: asdifobs(1) ! observed asdif +real(r8), public :: co2vmrobs(1) ! observed co2vmr +real(r8), public :: ch4vmrobs(1) ! observed ch3vmr +real(r8), public :: n2ovmrobs(1) ! observed n2ovmr +real(r8), public :: f11vmrobs(1) ! observed f11vmr +real(r8), public :: f12vmrobs(1) ! observed f12vmr +real(r8), public :: soltsiobs(1) ! observed solar + real(r8), public :: wfld(plev) ! Vertical motion (slt) real(r8), public :: wfldh(plevp) ! Vertical motion (slt) real(r8), public :: divq(plev,pcnst) ! Divergence of moisture @@ -144,6 +168,7 @@ module scamMod logical, public :: doiopupdate = .false. ! do we need to read next iop timepoint logical, public :: have_lhflx = .false. ! dataset contains lhflx logical, public :: have_shflx = .false. ! dataset contains shflx +logical, public :: have_heat_glob = .false. ! dataset contains shflx logical, public :: have_tg = .false. ! dataset contains tg logical, public :: have_tsair = .false. ! dataset contains tsair logical, public :: have_divq = .false. ! dataset contains divq @@ -191,15 +216,17 @@ module scamMod logical, public :: scm_cambfb_mode = .false. ! Use extra CAM IOP fields to assure bit for bit match with CAM run logical, public :: scm_use_obs_T = .false. ! Use the SCAM-IOP specified observed T at each time step instead of forecasting. logical, public :: scm_force_latlon = .false. ! force scam to use the lat lon fields specified in the scam namelist not what is closest to iop avail lat lon -real*8, public :: scm_relax_top_p = 1.e36_r8 ! upper bound for scm relaxation -real*8, public :: scm_relax_bot_p = -1.e36_r8 ! lower bound for scm relaxation -real*8, public :: scm_relax_tau_sec = 10800._r8 ! relaxation time constant (sec) +real(r8), public :: scm_relaxation_low ! lowest level to apply relaxation +real(r8), public :: scm_relaxation_high ! highest level to apply relaxation +real(r8), public :: scm_relax_top_p = 1.e36_r8 ! upper bound for scm relaxation +real(r8), public :: scm_relax_bot_p = -1.e36_r8 ! lower bound for scm relaxation +real(r8), public :: scm_relax_tau_sec = 10800._r8 ! relaxation time constant (sec) ! +++BPM: ! modification... allow a linear ramp in relaxation time scale: logical, public :: scm_relax_linear = .false. -real*8, public :: scm_relax_tau_bot_sec = 10800._r8 -real*8, public :: scm_relax_tau_top_sec = 10800._r8 +real(r8), public :: scm_relax_tau_bot_sec = 10800._r8 +real(r8), public :: scm_relax_tau_top_sec = 10800._r8 character(len=26), public :: scm_relax_fincl(pcnst) ! @@ -209,11 +236,16 @@ module scamMod logical, public :: scm_use_obs_uv = .true. ! Use the SCAM-IOP specified observed u,v at each time step instead of forecasting. logical, public :: scm_use_obs_qv = .false. ! Use the SCAM-IOP specified observed qv at each time step instead of forecasting. +logical, public :: scm_use_3dfrc = .false. ! Use the CAM/SCAM-IOP 3d forcing if true, else use dycore vertical plus horizontal advective forcing logical, public :: scm_iop_lhflxshflxTg = .false. !turn off LW rad logical, public :: scm_iop_Tg = .false. !turn off LW rad character(len=200), public :: scm_clubb_iop_name ! IOP name for CLUBB +integer, allocatable, public :: tsec(:) +integer, public :: ntime +save bdate + !======================================================================= contains !======================================================================= @@ -224,8 +256,6 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) use units, only: getunit, freeunit use dycore, only: dycore_is use wrap_nf, only: wrap_open - use spmd_utils, only : masterproc,npes - use netcdf, only : nf90_inquire_attribute,NF90_NOERR,NF90_GLOBAL,NF90_NOWRITE !---------------------------Arguments----------------------------------- @@ -248,7 +278,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) namelist /scam_nl/ iopfile, scm_iop_lhflxshflxTg, scm_iop_Tg, scm_relaxation, & scm_relax_top_p,scm_relax_bot_p,scm_relax_tau_sec, & scm_cambfb_mode,scm_crm_mode,scm_zadv_uv,scm_zadv_T,scm_zadv_q,& - scm_use_obs_T, scm_use_obs_uv, scm_use_obs_qv, & + scm_use_obs_T, scm_use_obs_uv, scm_use_obs_qv, scm_use_3dfrc, & scm_relax_linear, scm_relax_tau_top_sec, & scm_relax_tau_bot_sec, scm_force_latlon, scm_relax_fincl, scm_backfill_iop_w_init @@ -261,7 +291,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) if( single_column ) then if( npes.gt.1) call endrun('SCAM_READNL: SCAM doesnt support using more than 1 pe.') - if (.not. dycore_is('EUL') .or. plon /= 1 .or. plat /=1 ) then + if ( .not. (dycore_is('EUL') .or. dycore_is('SE')) .or. plon /= 1 .or. plat /=1 ) then call endrun('SCAM_SETOPTS: must compile model for SCAM mode when namelist parameter single_column is .true.') endif @@ -335,6 +365,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) write (iulog,*) ' scm_relax_tau_top_sec = ',scm_relax_tau_top_sec write (iulog,*) ' scm_relax_top_p = ',scm_relax_top_p write (iulog,*) ' scm_use_obs_T = ',scm_use_obs_T + write (iulog,*) ' scm_use_3dfrc = ',scm_use_3dfrc write (iulog,*) ' scm_use_obs_qv = ',scm_use_obs_qv write (iulog,*) ' scm_use_obs_uv = ',scm_use_obs_uv write (iulog,*) ' scm_zadv_T = ',trim(scm_zadv_T) @@ -360,6 +391,1438 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) end subroutine scam_readnl +subroutine readiopdata(iop_update_phase1, hvcoord) +!jt subroutine readiopdata(timelevel) + + +!----------------------------------------------------------------------- +! +! Open and read netCDF file containing initial IOP conditions +! +!---------------------------Code history-------------------------------- +! +! Written by J. Truesdale August, 1996, revised January, 1998 +! +!----------------------------------------------------------------------- +!jt use prognostics, only: n3,t3,q3,u3,v3,ps + use ppgrid, only: begchunk, endchunk +!jt fix this circular depend use phys_grid, only: clat_p +!jt use commap, only: latdeg, clat + use hybvcoord_mod, only: hvcoord_t + use getinterpnetcdfdata, only: getinterpncdata + use shr_sys_mod, only: shr_sys_flush + use error_messages, only: handle_ncerr + use string_utils, only: to_lower + use wrap_nf, only: wrap_inq_dimid,wrap_get_vara_realx +!----------------------------------------------------------------------- + implicit none +#if ( defined RS6000 ) + implicit automatic ( a-z ) +#endif + + character(len=*), parameter :: sub = "read_iop_data" + +!------------------------------Input Arguments-------------------------- +! +!jt integer, optional, intent(in) :: timelevel +logical, intent(in) :: iop_update_phase1 +type (hvcoord_t), intent(in) :: hvcoord + +!------------------------------Locals----------------------------------- +! +!!$ integer ntimelevel + integer NCID, status + integer time_dimID, lev_dimID, lev_varID + integer tsec_varID, bdate_varID,varid + integer i,j + integer nlev + integer total_levs + integer u_attlen + + integer nstep + integer k, m + integer icldliq,icldice + integer inumliq,inumice,idx + integer closelatidx,closelonidx,latid,lonid,levid,timeid,ncolid,ncol + + logical have_srf ! value at surface is available + logical fill_ends ! + logical have_cnst(pcnst) + real(r8) closelat,closelon + real(r8) dummy + real(r8) lat,xlat + real(r8) srf(1) ! value at surface + real(r8) hyam(plev),hybm(plev) + real(r8) pmid(plev) ! pressure at model levels (time n) + real(r8) pint(plevp) ! pressure at model interfaces (n ) + real(r8) pdel(plev) ! pdel(k) = pint (k+1)-pint (k) + real(r8) weight + real(r8) tmpdata(1) + real(r8) coldata(plev) + real(r8), allocatable :: dplevs( : ) + integer strt4(4),cnt4(4) + character(len=16) :: lowername + character(len=128) :: units ! Units + integer, allocatable :: tsec(:) + + nstep = get_nstep() + fill_ends= .false. + +!!$ if (present(timelevel)) then +!!$ ntimelevel=timelevel +!!$ else +!!$ ntimelevel=n3 +!!$ end if + +! +! Open IOP dataset +! + call handle_ncerr( nf90_open (iopfile, 0, ncid),& + 'readiopdata.F90', __LINE__) + +! +! if the dataset is a CAM generated dataset set use_camiop to true +! CAM IOP datasets have a global attribute called CAM_GENERATED_IOP +! + if ( nf90_inquire_attribute( ncid, NF90_GLOBAL, 'CAM_GENERATED_FORCING', attnum=i )== NF90_NOERR ) then + use_camiop = .true. + else + use_camiop = .false. + endif + +!===================================================================== +! +! Read time variables + + + status = nf90_inq_dimid (ncid, 'time', time_dimID ) + if (status /= NF90_NOERR) then + status = nf90_inq_dimid (ncid, 'tsec', time_dimID ) + if (status /= NF90_NOERR) then + if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find dimension ID for time/tsec' + status = NF90_CLOSE ( ncid ) + call endrun + end if + end if + + call handle_ncerr( nf90_inquire_dimension( ncid, time_dimID, len=ntime ),& + 'readiopdata.F90', __LINE__) + + allocate(tsec(ntime)) + + status = nf90_inq_varid (ncid, 'tsec', tsec_varID ) + call handle_ncerr( nf90_get_var (ncid, tsec_varID, tsec),& + 'readiopdata.F90', __LINE__) + + status = nf90_inq_varid (ncid, 'nbdate', bdate_varID ) + if (status /= NF90_NOERR) then + status = nf90_inq_varid (ncid, 'bdate', bdate_varID ) + if (status /= NF90_NOERR) then + if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for bdate' + status = NF90_CLOSE ( ncid ) + call endrun + end if + end if + call handle_ncerr( nf90_get_var (ncid, bdate_varID, bdate),& + 'readiopdata.F90', __LINE__) + +! +!====================================================== +! read level data +! + status = NF90_INQ_DIMID( ncid, 'lev', lev_dimID ) + if ( status .ne. nf90_noerr ) then + if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable dim ID for lev' + status = NF90_CLOSE ( ncid ) + return + end if + + call handle_ncerr( nf90_inquire_dimension( ncid, lev_dimID, len=nlev ),& + 'readiopdata.F90', __LINE__) + + allocate(dplevs(nlev+1)) + + status = NF90_INQ_VARID( ncid, 'lev', lev_varID ) + if ( status .ne. nf90_noerr ) then + if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for lev' + status = NF90_CLOSE ( ncid ) + return + end if + + call handle_ncerr( nf90_get_var (ncid, lev_varID, dplevs(:nlev)),& + 'readiopdata.F90', __LINE__) +! +!CAM generated forcing already has pressure on millibars convert standard IOP if needed. +! + call handle_ncerr(nf90_inquire_attribute(ncid, lev_varID, 'units', len=u_attlen),& + 'readiopdata.F90', __LINE__) + call handle_ncerr(nf90_get_att(ncid, lev_varID, 'units', units),& + 'readiopdata.F90', __LINE__) + units=trim(to_lower(units(1:u_attlen))) + + if ( units=='pa' .or. units=='pascal' .or. units=='pascals' ) then +! +! convert pressure from Pascals to Millibars ( lev is expressed in pascals in iop datasets ) +! + do i=1,nlev + dplevs( i ) = dplevs( i )/100._r8 + end do + endif + + +!!$ call shr_scam_GetCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,closelatidx,closelonidx) +!!$ +!!$ lonid = 0 +!!$ latid = 0 +!!$ levid = 0 +!!$ timeid = 0 +!!$ +!!$ ncolstatus = NF90_INQ_DIMID( ncid, 'ncol', ncolid )==nf90_noerr +!!$ ncoldstatus = NF90_INQ_DIMID( ncid, 'ncol_d', ncoldid ) +!!$ if ( NF90_INQ_DIMID( ncid, 'lat', latid )==nf90_noerr .or. NF90_INQ_DIMID( ncid, 'lat_d', latid )==nf90_noerr ) then +!!$ +!!$ call wrap_inq_dimid(ncid, 'lat', latid) +!!$ call wrap_inq_dimid(ncid, 'lon', lonid) +!!$ call wrap_inq_dimid(ncid, 'lev', levid) +!!$ call wrap_inq_dimid(ncid, 'time', timeid) +!!$ +!!$ strt4(1) = closelonidx +!!$ strt4(2) = closelatidx +!!$ strt4(3) = iopTimeIdx +!!$ strt4(4) = 1 +!!$ cnt4(1) = 1 +!!$ cnt4(2) = 1 +!!$ cnt4(3) = 1 +!!$ cnt4(4) = 1 +!!$ else if ( NF90_INQ_DIMID( ncid, 'ncol', ncolid )==nf90_noerr .or. NF90_INQ_DIMID( ncid, 'ncol_d', ncoldid )==nf90_noerr ) then +!!$ call wrap_inq_dimid(ncid, 'ncol', ncolid) +!!$ call wrap_inq_dimid(ncid, 'lev', levid) +!!$ call wrap_inq_dimid(ncid, 'time', timeid) +!!$ +!!$ strt4(1) = closelonidx +!!$ strt4(2) = iopTimeIdx +!!$ strt4(3) = 1 +!!$ strt4(4) = 1 +!!$ cnt4(1) = 1 +!!$ cnt4(2) = 1 +!!$ cnt4(3) = 1 +!!$ cnt4(4) = 1 +!!$ end if + status = nf90_inq_varid( ncid, 'Ps', varid ) + if ( status .ne. nf90_noerr ) then + have_ps = .false. + if (masterproc) write(iulog,*) sub//':Could not find variable Ps' + if ( .not. scm_backfill_iop_w_init ) then + status = NF90_CLOSE( ncid ) + return + else + if ( is_first_step() .and. masterproc) write(iulog,*) 'Using pressure value from Analysis Dataset' + endif + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, psobs, strt4) + have_ps = .true. + endif + + +! If the IOP dataset has hyam,hybm,etc it is assumed to be a hybrid level +! dataset. + + status = nf90_inq_varid( ncid, 'hyam', varid ) + if ( status == nf90_noerr .and. have_ps) then + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, hyam, strt4) + status = nf90_inq_varid( ncid, 'hybm', varid ) + status = nf90_get_var(ncid, varid, hybm, strt4) + do i = 1, nlev + dplevs( i ) = 1000.0_r8 * hyam( i ) + psobs * hybm( i ) / 100.0_r8 + end do + endif + +! add the surface pressure to the pressure level data, so that +! surface boundary condition will be set properly, +! making sure that it is the highest pressure in the array. +! + + total_levs = nlev+1 + dplevs(nlev+1) = psobs/100.0_r8 ! ps is expressed in pascals + do i= nlev, 1, -1 + if ( dplevs(i) > psobs/100.0_r8) then + total_levs = i + dplevs(i) = psobs/100.0_r8 + end if + end do + if (.not. use_camiop ) then + nlev = total_levs + endif + if ( nlev == 1 ) then + if (masterproc) write(iulog,*) sub//':Error - Readiopdata.F: Ps too low!' + return + endif + +!===================================================================== +!get global vmrs from camiop file + status = nf90_inq_varid( ncid, 'co2vmr', varid ) + if ( status == nf90_noerr) then +! have_co2vmr=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,co2vmrobs) + else + write(6,*)'using column value of co2vmr from boundary data as global volume mixing ratio' + end if + status = nf90_inq_varid( ncid, 'ch4vmr', varid ) + if ( status == nf90_noerr) then +! have_ch4vmr=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,ch4vmrobs) + else + write(6,*)'using column value of ch4vmr from boundary data as global volume mixing ratio' + end if + status = nf90_inq_varid( ncid, 'n2ovmr', varid ) + if ( status == nf90_noerr) then +! have_n2ovmr=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,n2ovmrobs) + else + write(6,*)'using column value of n2ovmr from boundary data as global volume mixing ratio' + end if + status = nf90_inq_varid( ncid, 'f11vmr', varid ) + if ( status == nf90_noerr) then +! have_f11vmr=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,f11vmrobs) + else + write(6,*)'using column value of f11vmr from boundary data as global volume mixing ratio' + end if + status = nf90_inq_varid( ncid, 'f12vmr', varid ) + if ( status == nf90_noerr) then +! have_f12vmr=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,f12vmrobs) + else + write(6,*)'using column value of f12vmr from boundary data as global volume mixing ratio' + end if + status = nf90_inq_varid( ncid, 'soltsi', varid ) + if ( status == nf90_noerr) then +! have_soltsi=.true. + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,soltsiobs) + else + write(6,*)'using column value of soltsi from boundary data as global solar tsi' + end if +!===================================================================== +!get global vmrs from camiop file + + status = nf90_inq_varid( ncid, 'Tsair', varid ) + if ( status .ne. nf90_noerr ) then + have_tsair = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,tsair) + have_tsair = .true. + endif + +! +! read in Tobs For cam generated iop readin small t to avoid confusion +! with capital T defined in cam +! + +!!$ tobs(:)= t3(1,:,1,ntimelevel) + + if ( use_camiop ) then + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'t', have_tsair, & + tsair(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm,tobs, status ) + else + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'T', have_tsair, & + tsair(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tobs, status ) + endif + if ( status .ne. nf90_noerr ) then + have_t = .false. + if (masterproc) write(iulog,*) sub//':Could not find variable T' + if ( .not. scm_backfill_iop_w_init ) then + status = NF90_CLOSE( ncid ) + return + else + if (masterproc) write(iulog,*) sub//':Using value from Analysis Dataset' + endif +! +! set T3 to Tobs on first time step +! + else + have_t = .true. + endif + + status = nf90_inq_varid( ncid, 'Tg', varid ) + if (status .ne. nf90_noerr) then + if (masterproc) write(iulog,*) sub//':Could not find variable Tg on IOP dataset' + if ( have_tsair ) then + if (masterproc) write(iulog,*) sub//':Using Tsair' + tground = tsair ! use surface value from T field + have_Tg = .true. + else + have_Tg = .true. + if (masterproc) write(iulog,*) sub//':Using T at lowest level from IOP dataset' + tground = tobs(plev) + endif + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,tground) + have_Tg = .true. + endif + + status = nf90_inq_varid( ncid, 'qsrf', varid ) + + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + +!!$ if (is_first_step()) then +!!$ qinitobs(:,:)=q3(1,:,:,1,ntimelevel) +!!$ end if +!!$ +!!$ qobs(:)= q3(1,:,1,1,ntimelevel) + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & + srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, qobs, status ) + if ( status .ne. nf90_noerr ) then + have_q = .false. + if (masterproc) write(iulog,*) sub//':Could not find variable q' + if ( .not. scm_backfill_iop_w_init ) then + status = nf90_close( ncid ) + return + else + if (masterproc) write(iulog,*) sub//':Using values from Analysis Dataset' + endif + else + have_q = .true. + endif + + cldobs = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'cld', .false., & + dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldobs, status ) + if ( status .ne. nf90_noerr ) then + have_cld = .false. + else + have_cld = .true. + endif + + clwpobs = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'clwp', .false., & + dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, clwpobs, status ) + if ( status .ne. nf90_noerr ) then + have_clwp = .false. + else + have_clwp = .true. + endif + +! +! read divq (horizontal advection) +! + status = nf90_inq_varid( ncid, 'divqsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + divq(:,:)=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & + 'divq', have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq(:,1), status ) + if ( status .ne. nf90_noerr ) then + have_divq = .false. + else + have_divq = .true. + endif + +! +! read vertdivq if available +! + status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + vertdivq=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivq', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivq(:,1), status ) + if ( status .ne. nf90_noerr ) then + have_vertdivq = .false. + else + have_vertdivq = .true. + endif + + status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + +! +! add calls to get dynamics tendencies for all prognostic consts +! + divq3d=0._r8 + + do m = 1, pcnst + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dten', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq3d(:,m), status ) + if ( status .ne. nf90_noerr ) then + have_cnst(m) = .false. + divq3d(1:,m)=0._r8 + else + if (m==1) have_divq3d = .true. + have_cnst(m) = .true. + endif + + coldata = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dqfx', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, coldata, status ) + if ( STATUS .NE. NF90_NOERR ) then + dqfxcam(1,:,m)=0._r8 + else + dqfxcam(1,:,m)=coldata(:) + endif + + tmpdata = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_alph', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tmpdata, status ) + if ( status .ne. nf90_noerr ) then +! have_cnst(m) = .false. + alphacam(m)=0._r8 + else + alphacam(m)=tmpdata(1) +! have_cnst(m) = .true. + endif + + end do + + + numliqobs = 0._r8 + call cnst_get_ind('NUMLIQ', inumliq, abort=.false.) + if ( inumliq > 0 ) then + have_srf = .false. + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMLIQ', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numliqobs, status ) + if ( status .ne. nf90_noerr ) then + have_numliq = .false. + else + have_numliq = .true. +!!$ do i=1, PLEV +!!$ q3(1,i,inumliq,1,ntimelevel)=numliqobs(i) +!!$ end do + endif + else + have_numliq = .false. + end if + + have_srf = .false. + + cldliqobs = 0._r8 + call cnst_get_ind('CLDLIQ', icldliq, abort=.false.) + if ( icldliq > 0 ) then + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDLIQ', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldliqobs, status ) + if ( status .ne. nf90_noerr ) then + have_cldliq = .false. + else + have_cldliq = .true. +!!$ do i=1, PLEV +!!$ q3(1,i,icldliq,1,ntimelevel)=cldliqobs(i) +!!$ end do + endif + else + have_cldliq = .false. + endif + + cldiceobs = 0._r8 + call cnst_get_ind('CLDICE', icldice, abort=.false.) + if ( icldice > 0 ) then + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDICE', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldiceobs, status ) + if ( status .ne. nf90_noerr ) then + have_cldice = .false. + else + have_cldice = .true. +!!$ do i=1, PLEV +!!$ q3(1,i,icldice,1,ntimelevel)=cldiceobs(i) +!!$ end do + endif + else + have_cldice = .false. + endif + + numiceobs = 0._r8 + call cnst_get_ind('NUMICE', inumice, abort=.false.) + if ( inumice > 0 ) then + have_srf = .false. + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMICE', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numiceobs, status ) + if ( status .ne. nf90_noerr ) then + have_numice = .false. + else + have_numice = .true. +!!$ do i=1, PLEV +!!$ q3(1,i,inumice,1,ntimelevel)=numiceobs(i) +!!$ end do + endif + else + have_numice = .false. + end if + +! +! read divu (optional field) +! + status = nf90_inq_varid( ncid, 'divusrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + divu = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divu', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu, status ) + if ( status .ne. nf90_noerr ) then + have_divu = .false. + else + have_divu = .true. + endif +! +! read divv (optional field) +! + status = nf90_inq_varid( ncid, 'divvsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + divv = 0._r8 + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divv', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv, status ) + if ( status .ne. nf90_noerr ) then + have_divv = .false. + else + have_divv = .true. + endif +! +! read divt (optional field) +! + status = nf90_inq_varid( ncid, 'divtsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + divt=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & + 'divT', have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt, status ) + if ( status .ne. nf90_noerr ) then + have_divt = .false. + else + have_divt = .true. + endif + +! +! read vertdivt if available +! + status = nf90_inq_varid( ncid, 'vertdivTsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + vertdivt=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) + if ( status .ne. nf90_noerr ) then + have_vertdivt = .false. + else + have_vertdivt = .true. + endif +! +! read divt3d (combined vertical/horizontal advection) +! (optional field) + + status = nf90_inq_varid( ncid, 'divT3dsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_srf = .true. + endif + + divT3d = 0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divT3d', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt3d, status ) + if ( status .ne. nf90_noerr ) then + have_divt3d = .false. + else + have_divt3d = .true. + endif + + divU3d = 0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divU3d', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu3d, status ) + if ( status .ne. nf90_noerr ) then + have_divu3d = .false. + else + have_divu3d = .true. + endif + + divV3d = 0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divV3d', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv3d, status ) + if ( status .ne. nf90_noerr ) then + have_divv3d = .false. + else + have_divv3d = .true. + endif + + status = nf90_inq_varid( ncid, 'Ptend', varid ) + if ( status .ne. nf90_noerr ) then + have_ptend = .false. + if (masterproc) write(iulog,*) sub//':Could not find variable Ptend. Setting to zero' + ptend = 0.0_r8 + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + have_ptend = .true. + ptend= srf(1) + endif + + wfld=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & + 'omega', .true., ptend, fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, wfld, status ) + if ( status .ne. nf90_noerr ) then + have_omega = .false. + if (masterproc) write(iulog,*) sub//':Could not find variable omega' + if ( .not. scm_backfill_iop_w_init ) then + status = nf90_close( ncid ) + return + else + if (masterproc) write(iulog,*) sub//'Using value from Analysis Dataset' + endif + else + have_omega = .true. + endif + call plevs0(plev ,psobs ,pint,pmid ,pdel, hvcoord) + call shr_sys_flush( iulog ) +! +! Build interface vector for the specified omega profile +! (weighted average in pressure of specified level values) +! + wfldh(:) = 0.0_r8 + + do k=2,plev + weight = (pint(k) - pmid(k-1))/(pmid(k) - pmid(k-1)) + wfldh(k) = (1.0_r8 - weight)*wfld(k-1) + weight*wfld(k) + end do + + status = nf90_inq_varid( ncid, 'usrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,srf) + have_srf = .true. + endif + + uobs=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & + 'u', have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, uobs, status ) + if ( status .ne. nf90_noerr ) then + have_u = .false. + else + have_u = .true. +!!$ do i=1, PLEV +!!$ u3(1,i,1,ntimelevel) = uobs(i) ! set u to uobs at first time step +!!$ end do + endif + + status = nf90_inq_varid( ncid, 'vsrf', varid ) + if ( status .ne. nf90_noerr ) then + have_srf = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,srf) + have_srf = .true. + endif + + vobs=0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & + 'v', have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vobs, status ) + if ( status .ne. nf90_noerr ) then + have_v = .false. + else + have_v = .true. +!!$ do i=1, PLEV +!!$ v3(1,i,1,ntimelevel) = vobs(i) ! set u to uobs at first time step +!!$ end do + endif + call shr_sys_flush( iulog ) + + status = nf90_inq_varid( ncid, 'Prec', varid ) + if ( status .ne. nf90_noerr ) then + have_prec = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,precobs) + have_prec = .true. + endif + + q1obs = 0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q1', & + .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q1 at surface + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) + if ( status .ne. nf90_noerr ) then + have_q1 = .false. + else + have_q1 = .true. + endif + + q1obs = 0._r8 + + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q2', & + .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q2 at surface + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) + if ( status .ne. nf90_noerr ) then + have_q2 = .false. + else + have_q2 = .true. + endif + +! Test for BOTH 'lhflx' and 'lh' without overwriting 'have_lhflx'. +! Analagous changes made for the surface heat flux + + status = nf90_inq_varid( ncid, 'lhflx', varid ) + if ( status .ne. nf90_noerr ) then + status = nf90_inq_varid( ncid, 'lh', varid ) + if ( status .ne. nf90_noerr ) then + have_lhflx = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,lhflxobs) + have_lhflx = .true. + endif + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,lhflxobs) + have_lhflx = .true. + endif + + status = nf90_inq_varid( ncid, 'shflx', varid ) + if ( status .ne. nf90_noerr ) then + status = nf90_inq_varid( ncid, 'sh', varid ) + if ( status .ne. nf90_noerr ) then + have_shflx = .false. + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,shflxobs) + have_shflx = .true. + endif + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,shflxobs) + have_shflx = .true. + endif + + call shr_sys_flush( iulog ) + ! If REPLAY is used, then need to read in the global + ! energy fixer + status = nf90_inq_varid( ncid, 'heat_glob', varid ) + if (status .ne. nf90_noerr) then + have_heat_glob = .false. + else + call wrap_get_vara_realx (ncid,varid,strt4,cnt4,heat_glob_scm) + have_heat_glob = .true. + endif + +! +! fill in 3d forcing variables if we have both horizontal +! and vertical components, but not the 3d +! + if ( .not. have_cnst(1) .and. have_divq .and. have_vertdivq ) then + do k=1,plev + do m=1,pcnst + divq3d(k,m) = divq(k,m) + vertdivq(k,m) + enddo + enddo + have_divq3d = .true. + endif + + if ( .not. have_divt3d .and. have_divt .and. have_vertdivt ) then + if (masterproc) write(iulog,*) sub//'Don''t have divt3d - using divt and vertdivt' + do k=1,plev + divt3d(k) = divt(k) + vertdivt(k) + enddo + have_divt3d = .true. + endif +! +! make sure that use_3dfrc flag is set to true if we only have +! 3d forcing available +! + if (scm_use_3dfrc .and. (have_divt3d .or. have_divq3d)) then + use_3dfrc = .true. + else + use_3dfrc = .false. + endif + + call shr_sys_flush( iulog ) + +!!$ status = nf90_inq_varid( ncid, 'CLAT', varid ) +!!$ if ( status == nf90_noerr ) then +!!$ call wrap_get_vara_realx (ncid,varid,strt4,cnt4,clat) +!!$!jt fix this circ depend clat_p(1)=clat(1) +!!$ latdeg(1) = clat(1)*45._r8/atan(1._r8) +!!$ endif + + status = nf90_inq_varid( ncid, 'beta', varid ) + if ( status .ne. nf90_noerr ) then + betacam = 0._r8 + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + betacam=srf(1) + endif + + status = nf90_inq_varid( ncid, 'fixmas', varid ) + if ( status .ne. nf90_noerr ) then + fixmascam=1.0_r8 + else + call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) + status = nf90_get_var(ncid, varid, srf(1), strt4) + fixmascam=srf(1) + endif + + call shr_sys_flush( iulog ) + + status = nf90_close( ncid ) + call shr_sys_flush( iulog ) + + deallocate(dplevs,tsec) + + return +end subroutine readiopdata + +subroutine setiopupdate + +!----------------------------------------------------------------------- +! +! Open and read netCDF file to extract time information +! +!---------------------------Code history-------------------------------- +! +! Written by John Truesdale August, 1996 +! +!----------------------------------------------------------------------- + implicit none +#if ( defined RS6000 ) + implicit automatic (a-z) +#endif + character(len=*), parameter :: sub = "setiopupdate" + +!------------------------------Locals----------------------------------- + + integer NCID,i + integer tsec_varID, time_dimID + integer bdate_varID + integer STATUS + integer next_date, next_sec + integer :: ncsec,ncdate ! current time of day,date + integer :: yr, mon, day ! year, month, and day component + integer :: start_ymd,start_tod +!------------------------------------------------------------------------------ + + if ( is_first_step() ) then +! +! Open IOP dataset +! + STATUS = NF90_OPEN( iopfile, NF90_NOWRITE, NCID ) +! +! Read time (tsec) variable +! + STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) + if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & + sub//':ERROR - setiopupdate.F:', & + 'Cant get variable ID for tsec' + + STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) + if ( STATUS .NE. NF90_NOERR ) then + STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) + if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & + sub//':ERROR - setiopupdate.F:Cant get variable ID for bdate' + endif + + STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) + if ( STATUS .NE. NF90_NOERR ) then + STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) + if ( STATUS .NE. NF90_NOERR ) then + write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' + STATUS = NF90_CLOSE ( NCID ) + return + end if + end if + + if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & + sub//':ERROR - setiopupdate.F:Cant get variable dim ID for time' + + STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) + if ( STATUS .NE. NF90_NOERR ) then + if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get time dimlen' + endif + + STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) + if ( STATUS .NE. NF90_NOERR )then + if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable tsec' + endif + STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) + if ( STATUS .NE. NF90_NOERR )then + if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable bdate' + endif +! Close the netCDF file + STATUS = NF90_CLOSE( NCID ) +! +! determine the last date in the iop dataset +! + call timemgr_time_inc(bdate, 0, last_date, last_sec, inc_s=tsec(ntime)) +! +! set the iop dataset index +! + iopTimeIdx=0 + do i=1,ntime ! set the first ioptimeidx + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(i)) + call get_start_date(yr,mon,day,start_tod) + start_ymd = yr*10000 + mon*100 + day + + if ( start_ymd > next_date .or. (start_ymd == next_date & + .and. start_tod >= next_sec)) then + iopTimeIdx = i + endif + enddo + + call get_curr_date(yr,mon,day,ncsec) + ncdate=yr*10000 + mon*100 + day + + if (iopTimeIdx == 0.or.iopTimeIdx >= ntime) then + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(1)) + if (masterproc) then + write(iulog,*) 'Error::setiopupdate: Current model time does not fall within IOP period' + write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' + write(iulog,*) ' IOP start is ',next_date,' and ',next_sec,' seconds' + write(iulog,*) ' IOP end is ',last_date,' and ',last_sec,' seconds' + end if + call endrun + endif + + doiopupdate = .true. + +!------------------------------------------------------------------------------ +! Check if iop data needs to be updated and set doiopupdate accordingly +!------------------------------------------------------------------------------ + else ! endstep > 1 + + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) + + call get_curr_date(yr, mon, day, ncsec) + ncdate = yr*10000 + mon*100 + day + + if ( ncdate > next_date .or. (ncdate == next_date & + .and. ncsec >= next_sec)) then + iopTimeIdx = iopTimeIdx + 1 + doiopupdate = .true. +#if DEBUG > 2 + if (masterproc) write(iulog,*) sub//'nstep = ',get_nstep() + if (masterproc) write(iulog,*) sub//'ncdate=',ncdate,' ncsec=',ncsec + if (masterproc) write(iulog,*) sub//'next_date=',next_date,' next_sec=',next_sec + if (masterproc) write(iulog,*) sub//':******* do iop update' +#endif + else + doiopupdate = .false. + end if + endif ! if (endstep == 0 ) +! +! make sure we're +! not going past end of iop data +! + if ( ncdate > last_date .or. (ncdate == last_date & + .and. ncsec > last_sec)) then + if ( .not. scm_backfill_iop_w_init ) then + call endrun(sub//':ERROR - setiopupdate.c:Reached the end of the time varient dataset') + else + doiopupdate = .false. + end if + endif + +#if DEBUG > 1 + if (masterproc) write(iulog,*) sub//':iop time index = ' , ioptimeidx +#endif + + return + +end subroutine setiopupdate + !=============================================================================== +subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) + +!----------------------------------------------------------------------- +! +! Purpose: +! Define the pressures of the interfaces and midpoints from the +! coordinate definitions and the surface pressure. +! +! Method: +! +! Author: B. Boville +! +!----------------------------------------------------------------------- +! +! $Id$ +! $Author$ +! +!----------------------------------------------------------------------- + + use pmgrid, only: plev, plevp + use hybvcoord_mod, only : hvcoord_t + implicit none + + +!----------------------------------------------------------------------- + integer , intent(in) :: nver ! vertical dimension + real(r8), intent(in) :: ps ! Surface pressure (pascals) + real(r8), intent(out) :: pint(nver+1) ! Pressure at model interfaces + real(r8), intent(out) :: pmid(nver) ! Pressure at model levels + real(r8), intent(out) :: pdel(nver) ! Layer thickness (pint(k+1) - pint(k)) + type (hvcoord_t), intent(in) :: hvcoord +!----------------------------------------------------------------------- + +!---------------------------Local workspace----------------------------- + integer k ! Longitude, level indices +!----------------------------------------------------------------------- +! +! Set interface pressures +! +!$OMP PARALLEL DO PRIVATE (K, I) + do k=1,nver+1 + pint(k) = hvcoord%hyai(k)*hvcoord%ps0 + hvcoord%hybi(k)*ps + end do +! +! Set midpoint pressures and layer thicknesses +! +!$OMP PARALLEL DO PRIVATE (K) + do k=1,nver + pmid(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*ps + pdel(k) = pint(k+1) - pint(k) + end do + + return +end subroutine plevs0 + +subroutine scmiop_flbc_inti ( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Get start count for variable + ! + ! Method: + ! + ! Author: + ! + !----------------------------------------------------------------------- + ! + ! $Id$ + ! $Author$ + ! + !----------------------------------------------------------------------- + + implicit none + + real(r8), intent(out) :: co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr + + !----------------------------------------------------------------------- + + co2vmr=co2vmrobs(1) + ch4vmr=ch4vmrobs(1) + n2ovmr=n2ovmrobs(1) + f11vmr=f11vmrobs(1) + f12vmr=f12vmrobs(1) +end subroutine scmiop_flbc_inti + +subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start ,count) + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! set global lower boundary conditions + ! + ! Method: + ! + ! Author: + ! + !----------------------------------------------------------------------- + ! + ! $Id$ + ! $Author$ + ! + !----------------------------------------------------------------------- + + implicit none + + +!----------------------------------------------------------------------- + integer , intent(in) :: ncid ! file id + integer , intent(in) :: varid ! variable id + integer , intent(in) :: TimeIdx ! time index + real(r8), intent(in) :: scmlat,scmlon! scm lat/lon + integer , intent(out) :: start(:),count(:) + +!---------------------------Local workspace----------------------------- + integer dims_set,nlev,var_ndims + logical usable_var + character dim_name*( 256 ) + integer var_dimIDs( NF90_MAX_VAR_DIMS ) + real(r8) closelat,closelon + integer latidx,lonidx,status,i +!----------------------------------------------------------------------- + + call shr_scam_GetCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx) + + STATUS = NF90_INQUIRE_VARIABLE( NCID, varID, ndims=var_ndims ) +! +! surface variables +! + if ( var_ndims .EQ. 0 ) then + call endrun('SCAMMOD: var_ndims is 0 for varid:',varid) + return + endif + + STATUS = NF90_INQUIRE_VARIABLE( NCID, varID, dimids=var_dimIDs) + if ( STATUS .NE. NF90_NOERR ) then + write(iulog,* ) 'ERROR - extractdata.F:Cant get dimension IDs for varid', varid + return + endif +! +! Initialize the start and count arrays +! + dims_set = 0 + nlev = 1 + do i = var_ndims, 1, -1 + + usable_var = .false. + STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), dim_name ) + + if ( trim(dim_name) .EQ. 'lat' ) then + start( i ) = latIdx + count( i ) = 1 ! Extract a single value + dims_set = dims_set + 1 + usable_var = .true. + endif + + if ( trim(dim_name) .EQ. 'lon' .or. trim(dim_name) .EQ. 'ncol' .or. trim(dim_name) .EQ. 'ncol_d' ) then + start( i ) = lonIdx + count( i ) = 1 ! Extract a single value + dims_set = dims_set + 1 + usable_var = .true. + endif + + if ( trim(dim_name) .EQ. 'lev' ) then + STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), len=nlev ) + start( i ) = 1 + count( i ) = nlev ! Extract all levels + dims_set = dims_set + 1 + usable_var = .true. + endif + + if ( trim(dim_name) .EQ. 'ilev' ) then + STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), len=nlev ) + start( i ) = 1 + count( i ) = nlev ! Extract all levels + dims_set = dims_set + 1 + usable_var = .true. + endif + + if ( trim(dim_name) .EQ. 'time' .OR. trim(dim_name) .EQ. 'tsec' ) then + start( i ) = TimeIdx + count( i ) = 1 ! Extract a single value + dims_set = dims_set + 1 + usable_var = .true. + endif + end do + return + end subroutine get_start_count + +!========================================================================= +subroutine setiopupdate_init + +!----------------------------------------------------------------------- +! +! Open and read netCDF file to extract time information +! This subroutine should be called at the first SCM time step +! +!---------------------------Code history-------------------------------- +! +! Written by John Truesdale August, 1996 +! Modified for E3SM by Peter Bogenschutz 2017 - onward +! +!----------------------------------------------------------------------- + implicit none +#if ( defined RS6000 ) + implicit automatic (a-z) +#endif + +!------------------------------Locals----------------------------------- + + integer NCID,i + integer tsec_varID, time_dimID + integer bdate_varID + integer STATUS + integer next_date, next_sec + integer next_date_print, next_sec_print + integer :: ncsec,ncdate ! current time of day,date + integer :: yr, mon, day ! year, month, and day component + integer :: start_ymd,start_tod + logical :: doiter +!------------------------------------------------------------------------------ + + ! Open and read pertinent information from the IOP file + + STATUS = NF90_OPEN( iopfile, NF90_NOWRITE, NCID ) + + ! Read time (tsec) variable + + STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) + if ( STATUS .NE. NF90_NOERR ) write(iulog,*)'ERROR - setiopupdate.F:', & + 'Cant get variable ID for tsec' + + STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) + if ( STATUS .NE. NF90_NOERR ) then + STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) + if ( STATUS .NE. NF90_NOERR ) & + write(iulog,*)'ERROR - setiopupdate.F:Cant get variable ID for bdate' + endif + + STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) + if ( STATUS .NE. NF90_NOERR ) then + STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) + if ( STATUS .NE. NF90_NOERR ) then + write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' + STATUS = NF90_CLOSE ( NCID ) + return + end if + end if + + if ( STATUS .NE. NF90_NOERR ) & + write(iulog,*)'ERROR - setiopupdate.F:Cant get variable dim ID for time' + + STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) + if ( STATUS .NE. NF90_NOERR )then + write(iulog,*)'ERROR - setiopupdate.F:Cant get time dimlen' + endif + + if (.not.allocated(tsec)) allocate(tsec(ntime)) + + STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) + if ( STATUS .NE. NF90_NOERR )then + write(iulog,*)'ERROR - setiopupdate.F:Cant get variable tsec' + endif + STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) + if ( STATUS .NE. NF90_NOERR )then + write(iulog,*)'ERROR - setiopupdate.F:Cant get variable bdate' + endif + + ! Close the netCDF file + STATUS = NF90_CLOSE( NCID ) + + ! determine the last date in the iop dataset + + call timemgr_time_inc(bdate, 0, last_date, last_sec, inc_s=tsec(ntime)) + + ! set the iop dataset index + iopTimeIdx=0 + do i=1,ntime ! set the first ioptimeidx + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(i)) + call get_start_date(yr,mon,day,start_tod) + start_ymd = yr*10000 + mon*100 + day + + if ( start_ymd .gt. next_date .or. (start_ymd .eq. next_date & + .and. start_tod .ge. next_sec)) then + iopTimeIdx = i + endif + enddo + + call get_curr_date(yr,mon,day,ncsec) + ncdate=yr*10000 + mon*100 + day + + if (iopTimeIdx == 0.or.iopTimeIdx .ge. ntime) then + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(1)) + write(iulog,*) 'Error::setiopupdate: Current model time does not fall within IOP period' + write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' + write(iulog,*) ' IOP start is ',next_date,' and ',next_sec,'seconds' + write(iulog,*) ' IOP end is ',last_date,' and ',last_sec,'seconds' + call endrun + endif + + doiopupdate = .true. + +end subroutine setiopupdate_init + end module scamMod diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 8b2ba903d0..090b7618a9 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -2030,6 +2030,10 @@ subroutine cam_set_mesh_for_single_column(scol_lon, scol_lat, mesh, rc) mincornerCoord(2) = scol_lat - .1_r8 ! min lat maxcornerCoord(1) = scol_lon + .1_r8 ! max lon maxcornerCoord(2) = scol_lat + .1_r8 ! max lat +!jt mincornerCoord(1) = scol_lon - fraction(scol_lon) ! min lon +!jt mincornerCoord(2) = scol_lat - fraction(scol_lat) ! min lat +!jt maxcornerCoord(1) = scol_lon + fraction(scol_lon) ! max lon +!jt maxcornerCoord(2) = scol_lat + fraction(scol_lat) ! max lat ! create the ESMF grid lgrid = ESMF_GridCreateNoPeriDimUfrm (maxindex=maxindex, & diff --git a/src/cpl/nuopc/atm_stream_ndep.F90 b/src/cpl/nuopc/atm_stream_ndep.F90 index 394808a529..0373416f4b 100644 --- a/src/cpl/nuopc/atm_stream_ndep.F90 +++ b/src/cpl/nuopc/atm_stream_ndep.F90 @@ -243,6 +243,8 @@ subroutine stream_ndep_interp(cam_out, rc) end if g = 1 + call truncate_precision(dataptr1d_nhx,size(dataptr1d_nhx),12) + call truncate_precision(dataptr1d_noy,size(dataptr1d_noy),12) do c = begchunk,endchunk do i = 1,get_ncols_p(c) cam_out(c)%nhx_nitrogen_flx(i) = dataptr1d_nhx(g) @@ -253,4 +255,27 @@ subroutine stream_ndep_interp(cam_out, rc) end subroutine stream_ndep_interp + !================================================================ + + subroutine truncate_precision(a, n, digits) + ! input/output variables + real(r8), dimension(n), & + & intent(inout) :: a + integer, intent(in) :: digits,n + + ! local variables + real(r8) :: scale(n),atmp(n),scale1(n) + + !----------------------------------------------------------------------- + + where (a == 0._r8) + a=0._r8 + elsewhere + scale=(floor(log10(dabs(a)))+1 - digits) + end where + scale=10**scale + a=scale*dint(a/scale) + end subroutine truncate_precision + + end module atm_stream_ndep diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90 index 24791ad0ed..79b7334dcc 100644 --- a/src/dynamics/eul/iop.F90 +++ b/src/dynamics/eul/iop.F90 @@ -10,34 +10,10 @@ module iop ! !USES: ! use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use constituents, only: readtrace, cnst_get_ind, pcnst, cnst_name + use constituents, only: pcnst use eul_control_mod, only: eul_nsplit - use netcdf, only: NF90_NOERR,NF90_CLOSE,NF90_GET_VAR,NF90_INQUIRE_DIMENSION, & - NF90_INQ_DIMID, NF90_INQ_VARID, NF90_NOWRITE, NF90_OPEN, & - NF90_GET_ATT,NF90_GLOBAL,NF90_INQUIRE_ATTRIBUTE - use phys_control, only: phys_getopts - use pmgrid, only: beglat,endlat,plon,plev,plevp - use prognostics, only: n3,t3,q3,u3,v3,ps - use scamMod, only: use_camiop, ioptimeidx, have_ps, scm_backfill_iop_w_init, have_tsair, & - tobs, have_t, tground, have_tg, qobs, have_q, have_cld, & - have_clwp, divq, have_divq, vertdivq, have_vertdivq, divq3d, & - have_divq3d, dqfxcam, have_numliq, have_cldliq, have_cldice, & - have_numice, have_divu, have_divv, divt, have_divt, vertdivt, & - have_vertdivt, divt3d, have_divt3d, have_divu3d, have_divv3d, & - have_ptend, ptend, wfld, uobs, have_u, uobs, vobs, have_v, & - vobs, have_prec, have_q1, have_q2, have_lhflx, have_shflx, & - use_3dfrc, betacam, fixmascam, alphacam, doiopupdate, & - cldiceobs, cldliqobs, cldobs, clwpobs, divu, & - divu3d, divv, divv3d, iopfile, lhflxobs, numiceobs, numliqobs, & - precobs, q1obs, scmlat, scmlon, shflxobs, tsair, have_omega, wfldh,qinitobs - use shr_kind_mod, only: r8 => shr_kind_r8, max_chars=>shr_kind_cl - use shr_scam_mod, only: shr_scam_GetCloseLatLon - use spmd_utils, only: masterproc - use string_utils, only: to_lower - use time_manager, only: timemgr_init, get_curr_date, get_curr_calday,& - get_nstep,is_first_step,get_start_date,timemgr_time_inc - use wrap_nf, only: wrap_inq_dimid,wrap_get_vara_realx + use pmgrid, only: beglat,endlat,plon,plev + use shr_kind_mod, only: r8 => shr_kind_r8 ! ! !PUBLIC TYPES: implicit none @@ -62,8 +38,6 @@ module iop ! ! !PUBLIC MEMBER FUNCTIONS: public :: init_iop_fields - public :: readiopdata ! read iop boundary data - public :: setiopupdate ! find index in iopboundary data for current time ! public :: scam_use_iop_srf ! !PUBLIC DATA: public betasav, & @@ -130,1026 +104,6 @@ subroutine init_iop_fields() endif end subroutine init_iop_fields -subroutine readiopdata(timelevel) - - -!----------------------------------------------------------------------- -! -! Open and read netCDF file containing initial IOP conditions -! -!---------------------------Code history-------------------------------- -! -! Written by J. Truesdale August, 1996, revised January, 1998 -! -!----------------------------------------------------------------------- - use ppgrid, only: begchunk, endchunk - use phys_grid, only: clat_p - use commap, only: latdeg, clat - use getinterpnetcdfdata, only: getinterpncdata - use shr_sys_mod, only: shr_sys_flush - use hycoef, only: hyam, hybm - use error_messages, only: handle_ncerr -!----------------------------------------------------------------------- - implicit none -#if ( defined RS6000 ) - implicit automatic ( a-z ) -#endif - - character(len=*), parameter :: sub = "read_iop_data" - -!------------------------------Input Arguments-------------------------- -! -integer, optional, intent(in) :: timelevel - -!------------------------------Locals----------------------------------- -! - integer ntimelevel - integer NCID, status - integer time_dimID, lev_dimID, lev_varID - integer tsec_varID, bdate_varID,varid - integer i,j - integer nlev - integer total_levs - integer u_attlen - - integer bdate, ntime,nstep - integer, allocatable :: tsec(:) - integer k, m - integer icldliq,icldice - integer inumliq,inumice,idx - - logical have_srf ! value at surface is available - logical fill_ends ! - logical have_cnst(pcnst) - real(r8) dummy - real(r8) lat,xlat - real(r8) srf(1) ! value at surface - real(r8) pmid(plev) ! pressure at model levels (time n) - real(r8) pint(plevp) ! pressure at model interfaces (n ) - real(r8) pdel(plev) ! pdel(k) = pint (k+1)-pint (k) - real(r8) weight - real(r8) tmpdata(1) - real(r8) coldata(plev) - real(r8), allocatable :: dplevs( : ) - integer strt4(4),cnt4(4),strt5(4),cnt5(4) - character(len=16) :: lowername - character(len=max_chars) :: units ! Units - - nstep = get_nstep() - fill_ends= .false. - - if (present(timelevel)) then - ntimelevel=timelevel - else - ntimelevel=n3 - end if - -! -! Open IOP dataset -! - call handle_ncerr( nf90_open (iopfile, 0, ncid),& - 'readiopdata.F90', __LINE__) - -! -! if the dataset is a CAM generated dataset set use_camiop to true -! CAM IOP datasets have a global attribute called CAM_GENERATED_IOP -! - if ( nf90_inquire_attribute( ncid, NF90_GLOBAL, 'CAM_GENERATED_FORCING', attnum=i )== NF90_NOERR ) then - use_camiop = .true. - else - use_camiop = .false. - endif - -!===================================================================== -! -! Read time variables - - - status = nf90_inq_dimid (ncid, 'time', time_dimID ) - if (status /= NF90_NOERR) then - status = nf90_inq_dimid (ncid, 'tsec', time_dimID ) - if (status /= NF90_NOERR) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find dimension ID for time/tsec' - status = NF90_CLOSE ( ncid ) - call endrun - end if - end if - - call handle_ncerr( nf90_inquire_dimension( ncid, time_dimID, len=ntime ),& - 'readiopdata.F90', __LINE__) - - allocate(tsec(ntime)) - - status = nf90_inq_varid (ncid, 'tsec', tsec_varID ) - call handle_ncerr( nf90_get_var (ncid, tsec_varID, tsec),& - 'readiopdata.F90', __LINE__) - - status = nf90_inq_varid (ncid, 'nbdate', bdate_varID ) - if (status /= NF90_NOERR) then - status = nf90_inq_varid (ncid, 'bdate', bdate_varID ) - if (status /= NF90_NOERR) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for bdate' - status = NF90_CLOSE ( ncid ) - call endrun - end if - end if - call handle_ncerr( nf90_get_var (ncid, bdate_varID, bdate),& - 'readiopdata.F90', __LINE__) - -! -!====================================================== -! read level data -! - status = NF90_INQ_DIMID( ncid, 'lev', lev_dimID ) - if ( status .ne. nf90_noerr ) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable dim ID for lev' - status = NF90_CLOSE ( ncid ) - return - end if - - call handle_ncerr( nf90_inquire_dimension( ncid, lev_dimID, len=nlev ),& - 'readiopdata.F90', __LINE__) - - allocate(dplevs(nlev+1)) - - status = NF90_INQ_VARID( ncid, 'lev', lev_varID ) - if ( status .ne. nf90_noerr ) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for lev' - status = NF90_CLOSE ( ncid ) - return - end if - - call handle_ncerr( nf90_get_var (ncid, lev_varID, dplevs(:nlev)),& - 'readiopdata.F90', __LINE__) -! -!CAM generated forcing already has pressure on millibars convert standard IOP if needed. -! - call handle_ncerr(nf90_inquire_attribute(ncid, lev_varID, 'units', len=u_attlen),& - 'readiopdata.F90', __LINE__) - call handle_ncerr(nf90_get_att(ncid, lev_varID, 'units', units),& - 'readiopdata.F90', __LINE__) - units=trim(to_lower(units(1:u_attlen))) - - if ( units=='pa' .or. units=='pascal' .or. units=='pascals' ) then -! -! convert pressure from Pascals to Millibars ( lev is expressed in pascals in iop datasets ) -! - do i=1,nlev - dplevs( i ) = dplevs( i )/100._r8 - end do - endif - - - call shr_scam_GetCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,closelatidx,closelonidx) - - lonid = 0 - latid = 0 - levid = 0 - timeid = 0 - - call wrap_inq_dimid(ncid, 'lat', latid) - call wrap_inq_dimid(ncid, 'lon', lonid) - call wrap_inq_dimid(ncid, 'lev', levid) - call wrap_inq_dimid(ncid, 'time', timeid) - - strt4(1) = closelonidx - strt4(2) = closelatidx - strt4(3) = iopTimeIdx - strt4(4) = 1 - cnt4(1) = 1 - cnt4(2) = 1 - cnt4(3) = 1 - cnt4(4) = 1 - - status = nf90_inq_varid( ncid, 'Ps', varid ) - if ( status .ne. nf90_noerr ) then - have_ps = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable Ps' - if ( .not. scm_backfill_iop_w_init ) then - status = NF90_CLOSE( ncid ) - return - else - if ( is_first_step() .and. masterproc) write(iulog,*) 'Using pressure value from Analysis Dataset' - endif - else - status = nf90_get_var(ncid, varid, ps(1,1,ntimelevel), strt4) - have_ps = .true. - endif - - -! If the IOP dataset has hyam,hybm,etc it is assumed to be a hybrid level -! dataset. - - status = nf90_inq_varid( ncid, 'hyam', varid ) - if ( status == nf90_noerr ) then - do i = 1, nlev - dplevs( i ) = 1000.0_r8 * hyam( i ) + ps(1,1,ntimelevel) * hybm( i ) / 100.0_r8 - end do - endif - -! add the surface pressure to the pressure level data, so that -! surface boundary condition will be set properly, -! making sure that it is the highest pressure in the array. -! - - total_levs = nlev+1 - dplevs(nlev+1) = ps(1,1,ntimelevel)/100.0_r8 ! ps is expressed in pascals - do i= nlev, 1, -1 - if ( dplevs(i) > ps(1,1,ntimelevel)/100.0_r8) then - total_levs = i - dplevs(i) = ps(1,1,ntimelevel)/100.0_r8 - end if - end do - if (.not. use_camiop ) then - nlev = total_levs - endif - if ( nlev == 1 ) then - if (masterproc) write(iulog,*) sub//':Error - Readiopdata.F: Ps too low!' - return - endif - -!===================================================================== - - - status = nf90_inq_varid( ncid, 'Tsair', varid ) - if ( status .ne. nf90_noerr ) then - have_tsair = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,tsair) - have_tsair = .true. - endif - -! -! read in Tobs For cam generated iop readin small t to avoid confusion -! with capital T defined in cam -! - - tobs(:)= t3(1,:,1,ntimelevel) - - if ( use_camiop ) then - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'t', have_tsair, & - tsair(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel),tobs, status ) - else - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'T', have_tsair, & - tsair(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), tobs, status ) - endif - if ( status .ne. nf90_noerr ) then - have_t = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable T' - if ( .not. scm_backfill_iop_w_init ) then - status = NF90_CLOSE( ncid ) - return - else - if (masterproc) write(iulog,*) sub//':Using value from Analysis Dataset' - endif -! -! set T3 to Tobs on first time step -! - else - have_t = .true. - endif - - status = nf90_inq_varid( ncid, 'Tg', varid ) - if (status .ne. nf90_noerr) then - if (masterproc) write(iulog,*) sub//':Could not find variable Tg on IOP dataset' - if ( have_tsair ) then - if (masterproc) write(iulog,*) sub//':Using Tsair' - tground = tsair ! use surface value from T field - have_Tg = .true. - else - have_Tg = .true. - if (masterproc) write(iulog,*) sub//':Using T at lowest level from IOP dataset' - tground = tobs(plev) - endif - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,tground) - have_Tg = .true. - endif - - status = nf90_inq_varid( ncid, 'qsrf', varid ) - - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - if (is_first_step()) then - qinitobs(:,:)=q3(1,:,:,1,ntimelevel) - end if - - qobs(:)= q3(1,:,1,1,ntimelevel) - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & - srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), qobs, status ) - if ( status .ne. nf90_noerr ) then - have_q = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable q' - if ( .not. scm_backfill_iop_w_init ) then - status = nf90_close( ncid ) - return - else - if (masterproc) write(iulog,*) sub//':Using values from Analysis Dataset' - endif - else - have_q = .true. - endif - - cldobs = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'cld', .false., & - dummy, fill_ends, dplevs, nlev,ps(1,1,ntimelevel), cldobs, status ) - if ( status .ne. nf90_noerr ) then - have_cld = .false. - else - have_cld = .true. - endif - - clwpobs = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'clwp', .false., & - dummy, fill_ends, dplevs, nlev,ps(1,1,ntimelevel), clwpobs, status ) - if ( status .ne. nf90_noerr ) then - have_clwp = .false. - else - have_clwp = .true. - endif - -! -! read divq (horizontal advection) -! - status = nf90_inq_varid( ncid, 'divqsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - divq(:,:)=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & - 'divq', have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divq(:,1), status ) - if ( status .ne. nf90_noerr ) then - have_divq = .false. - else - have_divq = .true. - endif - -! -! read vertdivq if available -! - status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - vertdivq=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivq', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), vertdivq(:,1), status ) - if ( status .ne. nf90_noerr ) then - have_vertdivq = .false. - else - have_vertdivq = .true. - endif - - status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - -! -! add calls to get dynamics tendencies for all prognostic consts -! - divq3d=0._r8 - - do m = 1, pcnst - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dten', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divq3d(:,m), status ) - if ( status .ne. nf90_noerr ) then - have_cnst(m) = .false. - divq3d(1:,m)=0._r8 - else - if (m==1) have_divq3d = .true. - have_cnst(m) = .true. - endif - - coldata = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dqfx', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), coldata, status ) - if ( STATUS .NE. NF90_NOERR ) then - dqfxcam(1,:,m)=0._r8 - else - dqfxcam(1,:,m)=coldata(:) - endif - - tmpdata = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_alph', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), tmpdata, status ) - if ( status .ne. nf90_noerr ) then -! have_cnst(m) = .false. - alphacam(m)=0._r8 - else - alphacam(m)=tmpdata(1) -! have_cnst(m) = .true. - endif - - end do - - - numliqobs = 0._r8 - call cnst_get_ind('NUMLIQ', inumliq, abort=.false.) - if ( inumliq > 0 ) then - have_srf = .false. - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMLIQ', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), numliqobs, status ) - if ( status .ne. nf90_noerr ) then - have_numliq = .false. - else - have_numliq = .true. - do i=1, PLEV - q3(1,i,inumliq,1,ntimelevel)=numliqobs(i) - end do - endif - else - have_numliq = .false. - end if - - have_srf = .false. - - cldliqobs = 0._r8 - call cnst_get_ind('CLDLIQ', icldliq, abort=.false.) - if ( icldliq > 0 ) then - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDLIQ', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), cldliqobs, status ) - if ( status .ne. nf90_noerr ) then - have_cldliq = .false. - else - have_cldliq = .true. - do i=1, PLEV - q3(1,i,icldliq,1,ntimelevel)=cldliqobs(i) - end do - endif - else - have_cldliq = .false. - endif - - cldiceobs = 0._r8 - call cnst_get_ind('CLDICE', icldice, abort=.false.) - if ( icldice > 0 ) then - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDICE', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), cldiceobs, status ) - if ( status .ne. nf90_noerr ) then - have_cldice = .false. - else - have_cldice = .true. - do i=1, PLEV - q3(1,i,icldice,1,ntimelevel)=cldiceobs(i) - end do - endif - else - have_cldice = .false. - endif - - numiceobs = 0._r8 - call cnst_get_ind('NUMICE', inumice, abort=.false.) - if ( inumice > 0 ) then - have_srf = .false. - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMICE', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), numiceobs, status ) - if ( status .ne. nf90_noerr ) then - have_numice = .false. - else - have_numice = .true. - do i=1, PLEV - q3(1,i,inumice,1,ntimelevel)=numiceobs(i) - end do - endif - else - have_numice = .false. - end if - -! -! read divu (optional field) -! - status = nf90_inq_varid( ncid, 'divusrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - divu = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divu', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divu, status ) - if ( status .ne. nf90_noerr ) then - have_divu = .false. - else - have_divu = .true. - endif -! -! read divv (optional field) -! - status = nf90_inq_varid( ncid, 'divvsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - divv = 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divv', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divv, status ) - if ( status .ne. nf90_noerr ) then - have_divv = .false. - else - have_divv = .true. - endif -! -! read divt (optional field) -! - status = nf90_inq_varid( ncid, 'divtsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - divt=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & - 'divT', have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divt, status ) - if ( status .ne. nf90_noerr ) then - have_divt = .false. - else - have_divt = .true. - endif - -! -! read vertdivt if available -! - status = nf90_inq_varid( ncid, 'vertdivTsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - vertdivt=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), vertdivt, status ) - if ( status .ne. nf90_noerr ) then - have_vertdivt = .false. - else - have_vertdivt = .true. - endif -! -! read divt3d (combined vertical/horizontal advection) -! (optional field) - - status = nf90_inq_varid( ncid, 'divT3dsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_srf = .true. - endif - - divT3d = 0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divT3d', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divt3d, status ) - if ( status .ne. nf90_noerr ) then - have_divt3d = .false. - else - have_divt3d = .true. - endif - - divU3d = 0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divU3d', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divu3d, status ) - if ( status .ne. nf90_noerr ) then - have_divu3d = .false. - else - have_divu3d = .true. - endif - - divV3d = 0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divV3d', & - have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), divv3d, status ) - if ( status .ne. nf90_noerr ) then - have_divv3d = .false. - else - have_divv3d = .true. - endif - - status = nf90_inq_varid( ncid, 'Ptend', varid ) - if ( status .ne. nf90_noerr ) then - have_ptend = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable Ptend. Setting to zero' - ptend = 0.0_r8 - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - have_ptend = .true. - ptend= srf(1) - endif - - wfld=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & - 'omega', .true., ptend, fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), wfld, status ) - if ( status .ne. nf90_noerr ) then - have_omega = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable omega' - if ( .not. scm_backfill_iop_w_init ) then - status = nf90_close( ncid ) - return - else - if (masterproc) write(iulog,*) sub//'Using value from Analysis Dataset' - endif - else - have_omega = .true. - endif - call plevs0(1 ,plon ,plev ,ps(1,1,ntimelevel) ,pint,pmid ,pdel) - call shr_sys_flush( iulog ) -! -! Build interface vector for the specified omega profile -! (weighted average in pressure of specified level values) -! - wfldh(:) = 0.0_r8 - - do k=2,plev - weight = (pint(k) - pmid(k-1))/(pmid(k) - pmid(k-1)) - wfldh(k) = (1.0_r8 - weight)*wfld(k-1) + weight*wfld(k) - end do - - status = nf90_inq_varid( ncid, 'usrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,srf) - have_srf = .true. - endif - - uobs=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & - 'u', have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), uobs, status ) - if ( status .ne. nf90_noerr ) then - have_u = .false. - else - have_u = .true. - do i=1, PLEV - u3(1,i,1,ntimelevel) = uobs(i) ! set u to uobs at first time step - end do - endif - - status = nf90_inq_varid( ncid, 'vsrf', varid ) - if ( status .ne. nf90_noerr ) then - have_srf = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,srf) - have_srf = .true. - endif - - vobs=0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & - 'v', have_srf, srf(1), fill_ends, & - dplevs, nlev,ps(1,1,ntimelevel), vobs, status ) - if ( status .ne. nf90_noerr ) then - have_v = .false. - else - have_v = .true. - do i=1, PLEV - v3(1,i,1,ntimelevel) = vobs(i) ! set u to uobs at first time step - end do - endif - call shr_sys_flush( iulog ) - - status = nf90_inq_varid( ncid, 'Prec', varid ) - if ( status .ne. nf90_noerr ) then - have_prec = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,precobs) - have_prec = .true. - endif - - q1obs = 0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q1', & - .false., dummy, fill_ends, & ! datasets don't contain Q1 at surface - dplevs, nlev,ps(1,1,ntimelevel), q1obs, status ) - if ( status .ne. nf90_noerr ) then - have_q1 = .false. - else - have_q1 = .true. - endif - - q1obs = 0._r8 - - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q2', & - .false., dummy, fill_ends, & ! datasets don't contain Q2 at surface - dplevs, nlev,ps(1,1,ntimelevel), q1obs, status ) - if ( status .ne. nf90_noerr ) then - have_q2 = .false. - else - have_q2 = .true. - endif - -! Test for BOTH 'lhflx' and 'lh' without overwriting 'have_lhflx'. -! Analagous changes made for the surface heat flux - - status = nf90_inq_varid( ncid, 'lhflx', varid ) - if ( status .ne. nf90_noerr ) then - status = nf90_inq_varid( ncid, 'lh', varid ) - if ( status .ne. nf90_noerr ) then - have_lhflx = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,lhflxobs) - have_lhflx = .true. - endif - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,lhflxobs) - have_lhflx = .true. - endif - - status = nf90_inq_varid( ncid, 'shflx', varid ) - if ( status .ne. nf90_noerr ) then - status = nf90_inq_varid( ncid, 'sh', varid ) - if ( status .ne. nf90_noerr ) then - have_shflx = .false. - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,shflxobs) - have_shflx = .true. - endif - else - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,shflxobs) - have_shflx = .true. - endif - - call shr_sys_flush( iulog ) - -! -! fill in 3d forcing variables if we have both horizontal -! and vertical components, but not the 3d -! - if ( .not. have_cnst(1) .and. have_divq .and. have_vertdivq ) then - do k=1,plev - do m=1,pcnst - divq3d(k,m) = divq(k,m) + vertdivq(k,m) - enddo - enddo - have_divq3d = .true. - endif - - if ( .not. have_divt3d .and. have_divt .and. have_vertdivt ) then - if (masterproc) write(iulog,*) sub//'Don''t have divt3d - using divt and vertdivt' - do k=1,plev - divt3d(k) = divt(k) + vertdivt(k) - enddo - have_divt3d = .true. - endif -! -! make sure that use_3dfrc flag is set to true if we only have -! 3d forcing available -! - if ( .not. have_divt .or. .not. have_divq ) then - use_3dfrc = .true. - endif - call shr_sys_flush( iulog ) - - status = nf90_inq_varid( ncid, 'CLAT', varid ) - if ( status == nf90_noerr ) then - call wrap_get_vara_realx (ncid,varid,strt4,cnt4,clat) - clat_p(1)=clat(1) - latdeg(1) = clat(1)*45._r8/atan(1._r8) - endif - - status = nf90_inq_varid( ncid, 'beta', varid ) - if ( status .ne. nf90_noerr ) then - betacam = 0._r8 - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - betacam=srf(1) - endif - - status = nf90_inq_varid( ncid, 'fixmas', varid ) - if ( status .ne. nf90_noerr ) then - fixmascam=1.0_r8 - else - status = nf90_get_var(ncid, varid, srf(1), strt4) - fixmascam=srf(1) - endif - - call shr_sys_flush( iulog ) - - status = nf90_close( ncid ) - call shr_sys_flush( iulog ) - - deallocate(dplevs,tsec) - - return -end subroutine readiopdata - -subroutine setiopupdate - -!----------------------------------------------------------------------- -! -! Open and read netCDF file to extract time information -! -!---------------------------Code history-------------------------------- -! -! Written by John Truesdale August, 1996 -! -!----------------------------------------------------------------------- - implicit none -#if ( defined RS6000 ) - implicit automatic (a-z) -#endif - character(len=*), parameter :: sub = "setiopupdate" - -!------------------------------Locals----------------------------------- - - integer NCID,i - integer tsec_varID, time_dimID - integer, allocatable :: tsec(:) - integer ntime - integer bdate, bdate_varID - integer STATUS - integer next_date, next_sec, last_date, last_sec - integer :: ncsec,ncdate ! current time of day,date - integer :: yr, mon, day ! year, month, and day component - integer :: start_ymd,start_tod - save tsec, ntime, bdate - save last_date, last_sec -!------------------------------------------------------------------------------ - - if ( is_first_step() ) then -! -! Open IOP dataset -! - STATUS = NF90_OPEN( iopfile, NF90_NOWRITE, NCID ) -! -! Read time (tsec) variable -! - STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:', & - 'Cant get variable ID for tsec' - - STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR ) then - STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:Cant get variable ID for bdate' - endif - - STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then - STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then - write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' - STATUS = NF90_CLOSE ( NCID ) - return - end if - end if - - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:Cant get variable dim ID for time' - - STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) - if ( STATUS .NE. NF90_NOERR ) then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get time dimlen' - endif - - if (.not.allocated(tsec)) allocate(tsec(ntime)) - - STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) - if ( STATUS .NE. NF90_NOERR )then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable tsec' - endif - STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) - if ( STATUS .NE. NF90_NOERR )then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable bdate' - endif -! Close the netCDF file - STATUS = NF90_CLOSE( NCID ) -! -! determine the last date in the iop dataset -! - call timemgr_time_inc(bdate, 0, last_date, last_sec, inc_s=tsec(ntime)) -! -! set the iop dataset index -! - iopTimeIdx=0 - do i=1,ntime ! set the first ioptimeidx - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(i)) - call get_start_date(yr,mon,day,start_tod) - start_ymd = yr*10000 + mon*100 + day - - if ( start_ymd > next_date .or. (start_ymd == next_date & - .and. start_tod >= next_sec)) then - iopTimeIdx = i - endif - enddo - - call get_curr_date(yr,mon,day,ncsec) - ncdate=yr*10000 + mon*100 + day - - if (iopTimeIdx == 0.or.iopTimeIdx >= ntime) then - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(1)) - if (masterproc) then - write(iulog,*) 'Error::setiopupdate: Current model time does not fall within IOP period' - write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' - write(iulog,*) ' IOP start is ',next_date,' and ',next_sec,' seconds' - write(iulog,*) ' IOP end is ',last_date,' and ',last_sec,' seconds' - end if - call endrun - endif - - doiopupdate = .true. - -!------------------------------------------------------------------------------ -! Check if iop data needs to be updated and set doiopupdate accordingly -!------------------------------------------------------------------------------ - else ! endstep > 1 - - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) - - call get_curr_date(yr, mon, day, ncsec) - ncdate = yr*10000 + mon*100 + day - - if ( ncdate > next_date .or. (ncdate == next_date & - .and. ncsec >= next_sec)) then - iopTimeIdx = iopTimeIdx + 1 - doiopupdate = .true. -#if DEBUG > 2 - if (masterproc) write(iulog,*) sub//'nstep = ',get_nstep() - if (masterproc) write(iulog,*) sub//'ncdate=',ncdate,' ncsec=',ncsec - if (masterproc) write(iulog,*) sub//'next_date=',next_date,' next_sec=',next_sec - if (masterproc) write(iulog,*) sub//':******* do iop update' -#endif - else - doiopupdate = .false. - end if - endif ! if (endstep == 0 ) -! -! make sure we're -! not going past end of iop data -! - if ( ncdate > last_date .or. (ncdate == last_date & - .and. ncsec > last_sec)) then - if ( .not. scm_backfill_iop_w_init ) then - call endrun(sub//':ERROR - setiopupdate.c:Reached the end of the time varient dataset') - else - doiopupdate = .false. - end if - endif - -#if DEBUG > 1 - if (masterproc) write(iulog,*) sub//':iop time index = ' , ioptimeidx -#endif - - return - -end subroutine setiopupdate end module iop diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 new file mode 100644 index 0000000000..500a092ecc --- /dev/null +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -0,0 +1,175 @@ +module apply_iop_forcing_mod + +use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8 +use pmgrid +use constituents, only: pcnst, cnst_get_ind +use physconst, only: rair,cpair +use cam_logfile, only: iulog +use hybvcoord_mod, only : hvcoord_t +!use camiop, only: use_3dfrc, single_column, have_u, have_v, divT3d, divq3d, divt, divq, & +! wfld, uobs, vobs, tobs, qobs +use scamMod, only: use_3dfrc, single_column, have_u, have_v, divT3d, divq3d, divt, divq, & + wfld, uobs, vobs, tobs, qobs, plevs0 +implicit none + +public advance_iop_forcing +public advance_iop_nudging + +!========================================================================= +contains +!========================================================================= + +subroutine advance_iop_forcing(scm_dt, ps_in, & ! In + u_in, v_in, t_in, q_in, t_phys_frc,hvcoord, & ! In + u_update, v_update, t_update, q_update) ! Out + +!----------------------------------------------------------------------- +! +! Purpose: +! Apply large scale forcing for t, q, u, and v as provided by the +! case IOP forcing file. +! +! Author: +! Original version: Adopted from CAM3.5/CAM5 +! Updated version for E3SM: Peter Bogenschutz (bogenschutz1@llnl.gov) +! and replaces the forecast.F90 routine in CAM3.5/CAM5/CAM6/E3SMv1/E3SMv2 +! +!----------------------------------------------------------------------- + + ! Input arguments + real(r8), intent(in) :: ps_in ! surface pressure [Pa] + real(r8), intent(in) :: u_in(plev) ! zonal wind [m/s] + real(r8), intent(in) :: v_in(plev) ! meridional wind [m/s] + real(r8), intent(in) :: t_in(plev) ! temperature [K] + real(r8), intent(in) :: q_in(plev,pcnst) ! q tracer array [units vary] + real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] + type (hvcoord_t), intent(in) :: hvcoord + real(r8), intent(in) :: scm_dt ! model time step [s] + + ! Output arguments + real(r8), intent(out) :: t_update(plev) ! updated temperature [K] + real(r8), intent(out) :: q_update(plev,pcnst)! updated q tracer array [units vary] + real(r8), intent(out) :: u_update(plev) ! updated zonal wind [m/s] + real(r8), intent(out) :: v_update(plev) ! updated meridional wind [m/s] + + ! Local variables + real(r8) pmidm1(plev) ! pressure at model levels + real(r8) pintm1(plevp) ! pressure at model interfaces + real(r8) pdelm1(plev) ! pdel(k) = pint (k+1)-pint (k) + real(r8) t_lsf(plev) ! storage for temperature large scale forcing + real(r8) q_lsf(plev,pcnst) ! storage for moisture large scale forcing + real(r8) fac, t_expan + + integer i,k,m ! longitude, level, constituent indices + integer nlon + + !! Get vertical level profiles + + nlon = 1 ! number of columns for plevs0 routine + call plevs0(plev ,ps_in ,pintm1 ,pmidm1 ,pdelm1, hvcoord) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Advance T and Q due to large scale forcing + + if (use_3dfrc) then + t_lsf(:plev) = divt3d(:plev) + q_lsf(:plev,:pcnst) = divq3d(:plev,:pcnst) + else + t_lsf(:plev) = divt(:plev) + q_lsf(:plev,:pcnst) = divq(:plev,:pcnst) + endif + + do k=1,plev + ! Initialize thermal expansion term to zero. This term is only + ! considered if using the preq-x dycore and if three dimensional + ! forcing is not provided by IOP forcing file. + t_expan = 0._r8 + + if (.not. use_3dfrc) then + t_expan = scm_dt*wfld(k)*t_in(k)*rair/(cpair*pmidm1(k)) + endif + + t_update(k) = t_in(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) + do m=1,pcnst + q_update(k,m) = q_in(k,m) + scm_dt*q_lsf(k,m) + end do + enddo + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set U and V fields + + if ( have_v .and. have_u ) then + do k=1,plev + u_update(k) = uobs(k) + v_update(k) = vobs(k) + enddo + endif + +end subroutine advance_iop_forcing + +!========================================================================= + +subroutine advance_iop_nudging(scm_dt, ps_in, t_in, q_in, hvcoord, & ! In + t_update, q_update, relaxt, relaxq ) ! Out + +!----------------------------------------------------------------------- +! +! Purpose: +! Option to nudge t and q to observations as specified by the IOP file +!----------------------------------------------------------------------- + + ! Input arguments + real(r8), intent(in) :: scm_dt ! model time step [s] + real(r8), intent(in) :: ps_in ! surface pressure [Pa] + real(r8), intent(in) :: t_in(plev) ! temperature [K] + real(r8), intent(in) :: q_in(plev) ! water vapor mixing ratio [kg/kg] + type (hvcoord_t), intent(in) :: hvcoord + + ! Output arguments + real(r8), intent(out) :: t_update(plev) ! updated temperature [K] + real(r8), intent(out) :: q_update(plev) ! updated water vapor [kg/kg] + real(r8), intent(out) :: relaxt(plev) ! relaxation of temperature [K/s] + real(r8), intent(out) :: relaxq(plev) ! relaxation of vapor [kg/kg/s] + + ! Local variables + integer :: k, nlon + real(r8) rtau(plev) + real(r8) pmidm1(plev) ! pressure at model levels + real(r8) pintm1(plevp) ! pressure at model interfaces + real(r8) pdelm1(plev) ! pdel(k) = pint (k+1)-pint (k) + + nlon = 1 ! number of columns for plevs0 routine + call plevs0(plev ,ps_in ,pintm1 ,pmidm1 ,pdelm1, hvcoord) + + ! Set relaxation arrays to zero + do k=1,plev + relaxt(k) = 0.0_r8 + relaxq(k) = 0.0_r8 + end do + + do k=1,plev + +!jt if (pmidm1(k) .le. iop_nudge_tq_low*100._r8 .and. & +!jt pmidm1(k) .ge. iop_nudge_tq_high*100._r8) then + + ! Set the relaxation time scale +!jt rtau(k) = iop_nudge_tscale +!jt rtau(k) = max(scm_dt,rtau(k)) + rtau(k) = scm_dt + relaxt(k) = -(t_update(k) - tobs(k))/rtau(k) + relaxq(k) = -(q_update(k) - qobs(k))/rtau(k) + + t_update(k) = t_update(k) + relaxt(k)*scm_dt + q_update(k) = q_update(k) + relaxq(k)*scm_dt + +!jt endif + + end do + +end subroutine advance_iop_nudging + +!----------------------------------------------------------------------- + +end module apply_iop_forcing_mod + + diff --git a/src/dynamics/se/dp_coupling.F90 b/src/dynamics/se/dp_coupling.F90 index 7dae784315..eb736ec232 100644 --- a/src/dynamics/se/dp_coupling.F90 +++ b/src/dynamics/se/dp_coupling.F90 @@ -15,7 +15,7 @@ module dp_coupling use physics_types, only: physics_state, physics_tend, physics_cnst_limit use phys_grid, only: get_ncols_p -use phys_grid, only: get_dyn_col_p, columns_on_task, get_chunk_info_p +use phys_grid, only: get_dyn_col_p, columns_on_task, get_chunk_info_p, phys_columns_on_task use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field use dp_mapping, only: nphys_pts @@ -224,7 +224,7 @@ subroutine d_p_coupling(phys_state, phys_tend, pbuf2d, dyn_out) allocate(frontga_phys(pcols, pver, begchunk:endchunk)) end if !$omp parallel do num_threads(max_num_threads) private (col_ind, lchnk, icol, ie, blk_ind, ilyr, m) - do col_ind = 1, columns_on_task + do col_ind = 1, phys_columns_on_task call get_dyn_col_p(col_ind, ie, blk_ind) call get_chunk_info_p(col_ind, lchnk, icol) phys_state(lchnk)%ps(icol) = ps_tmp(blk_ind(1), ie) @@ -306,7 +306,7 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) ! Convert the physics output state into the dynamics input state. - use phys_grid, only: get_dyn_col_p, columns_on_task, get_chunk_info_p + use phys_grid, only: get_dyn_col_p, columns_on_task, get_chunk_info_p, phys_columns_on_task use bndry_mod, only: bndry_exchange use edge_mod, only: edgeVpack, edgeVunpack use fvm_mapping, only: phys2dyn_forcings_fvm @@ -383,7 +383,7 @@ subroutine p_d_coupling(phys_state, phys_tend, dyn_in, tl_f, tl_qdp) call t_startf('pd_copy') !$omp parallel do num_threads(max_num_threads) private (col_ind, lchnk, icol, ie, blk_ind, ilyr, m) - do col_ind = 1, columns_on_task + do col_ind = 1, phys_columns_on_task call get_dyn_col_p(col_ind, ie, blk_ind) call get_chunk_info_p(col_ind, lchnk, icol) diff --git a/src/dynamics/se/dycore/prim_advance_mod.F90 b/src/dynamics/se/dycore/prim_advance_mod.F90 index c9f1ac194b..05a3425e83 100644 --- a/src/dynamics/se/dycore/prim_advance_mod.F90 +++ b/src/dynamics/se/dycore/prim_advance_mod.F90 @@ -1726,6 +1726,8 @@ subroutine compute_omega(hybrid,n0,qn0,elem,deriv,nets,nete,dt,hvcoord) use viscosity_mod, only: biharmonic_wk_omega use cam_thermo, only: get_dp, MASS_MIXING_RATIO use air_composition,only: thermodynamic_active_species_idx_dycore + use cam_logfile, only: iulog + implicit none type (hybrid_t) , intent(in) :: hybrid type (element_t) , intent(inout), target :: elem(:) diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index af22869f24..c1d35621eb 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -184,7 +184,7 @@ end subroutine prim_init2 !=======================================================================================================! - subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubstep, omega_cn) + subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubstep, single_column, omega_cn) ! ! advance all variables (u,v,T,ps,Q,C) from time t to t + dt_q ! @@ -238,10 +238,11 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep type (TimeLevel_t), intent(inout):: tl integer, intent(in) :: nsubstep ! nsubstep = 1 .. nsplit + logical, intent(in) :: single_column real (kind=r8) , intent(inout):: omega_cn(2,nets:nete) !min and max of vertical Courant number real(kind=r8) :: dt_q, dt_remap, dt_phys - integer :: ie, q,k,n0_qdp,np1_qdp,r, nstep_end,region_num_threads,i,j + integer :: ie, q,k,n0_qdp,np1_qdp,r, nstep_end,region_num_threads,i,j,nets_in,nete_in real (kind=r8) :: dp_np1(np,np) real (kind=r8) :: dp_start(np,np,nlev+1,nets:nete),dp_end(np,np,nlev,nets:nete) logical :: compute_diagnostics @@ -287,10 +288,16 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') do r=1,rsplit if (r.ne.1) call TimeLevel_update(tl,"leapfrog") - call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) + if (single_column) then + ! Single Column Case + ! Loop over rsplit vertically lagrangian timesiteps + call prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) + else + ! Loop over rsplit vertically lagrangian timesiteps + call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) + end if enddo - ! defer final timelevel update until after remap and diagnostics call TimeLevel_Qdp( tl, qsplit, n0_qdp, np1_qdp) @@ -310,8 +317,15 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst dp_end(:,:,:,ie) = elem(ie)%state%dp3d(:,:,:,tl%np1) end do end if +! if (single_column) then +! nets_in=1 +! nete_in=1 +! else + nets_in=nets + nete_in=nete +! endif call t_startf('vertical_remap') - call vertical_remap(hybrid,elem,fvm,hvcoord,tl%np1,np1_qdp,nets,nete) + call vertical_remap(hybrid,elem,fvm,hvcoord,tl%np1,np1_qdp,nets_in,nete_in) call t_stopf('vertical_remap') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -319,7 +333,8 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAR') - if (nsubstep==nsplit) then +!!jt check with pel that we don't want to update omega here for scm + if (nsubstep==nsplit.and. .not. single_column) then call compute_omega(hybrid,tl%np1,np1_qdp,elem,deriv,nets,nete,dt_remap,hvcoord) end if @@ -612,8 +627,106 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) endif end subroutine prim_step + subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) + ! + ! prim_step version for single column model (SCM) + ! Here we simply want to compute the floating level tendency + ! based on the prescribed large scale vertical velocity + ! Take qsplit dynamics steps and one tracer step + ! for vertically lagrangian option, this subroutine does only + ! the horizontal step + ! + ! input: + ! tl%nm1 not used + ! tl%n0 data at time t + ! tl%np1 new values at t+dt_q + ! + ! then we update timelevel pointers: + ! tl%nm1 = tl%n0 + ! tl%n0 = tl%np1 + ! so that: + ! tl%nm1 tracers: t dynamics: t+(qsplit-1)*dt + ! tl%n0 time t + dt_q + ! + use hybvcoord_mod, only: hvcoord_t + use time_mod, only: TimeLevel_t, timelevel_update + use control_mod, only: statefreq, qsplit, nu_p + use thread_mod, only: omp_get_thread_num + use prim_advance_mod, only: prim_advance_exp + use prim_advection_mod, only: prim_advec_tracers_remap, prim_advec_tracers_fvm, deriv + use derivative_mod, only: subcell_integration + use hybrid_mod, only: set_region_num_threads, config_thread_region, get_loop_ranges + use dimensions_mod, only: use_cslam,fvm_supercycling,fvm_supercycling_jet + use dimensions_mod, only: kmin_jet, kmax_jet + use fvm_mod, only: ghostBufQnhc_vh,ghostBufQ1_vh, ghostBufFlux_vh + use fvm_mod, only: ghostBufQ1_h,ghostBufQnhcJet_h, ghostBufFluxJet_h + +#ifdef waccm_debug + use cam_history, only: outfld +#endif + + + type (element_t) , intent(inout) :: elem(:) + type(fvm_struct), intent(inout) :: fvm(:) + type (hybrid_t), intent(in) :: hybrid ! distributed parallel structure (shared) + type (hvcoord_t), intent(in) :: hvcoord ! hybrid vertical coordinate struct + integer, intent(in) :: nets ! starting thread element number (private) + integer, intent(in) :: nete ! ending thread element number (private) + real(kind=r8), intent(in) :: dt ! "timestep dependent" timestep + type (TimeLevel_t), intent(inout) :: tl + integer, intent(in) :: rstep ! vertical remap subcycling step + + type (hybrid_t):: hybridnew,hybridnew2 + real(kind=r8) :: st, st1, dp + integer :: ie,t,q,k,i,j,n, n_Q + integer :: ithr + integer :: region_num_threads + integer :: kbeg,kend + + real (kind=r8) :: tempdp3d(np,np), x + real (kind=r8) :: tempmass(nc,nc) + real (kind=r8) :: tempflux(nc,nc,4) + + real (kind=r8) :: dp_np1(np,np) + ! =============== + ! initialize mean flux accumulation variables and save some variables at n0 + ! for use by advection + ! =============== + do ie=nets,nete +!jt elem(ie)%derived%eta_dot_dpdn=0 ! mean vertical mass flux + elem(ie)%derived%vn0=0 ! mean horizontal mass flux + if (nu_p>0) then + elem(ie)%derived%dpdiss_ave=0 + elem(ie)%derived%dpdiss_biharmonic=0 + endif + elem(ie)%derived%dp(:,:,:)=elem(ie)%state%dp3d(:,:,:,tl%n0) + enddo + + ! =============== + ! Dynamical Step + ! =============== + + call t_startf('prim_advance_exp') + + call set_prescribed_scm(elem, fvm, deriv, hvcoord, & + hybrid, dt, tl, nets, nete) + + call t_stopf('prim_advance_exp') + + do n=2,qsplit + call TimeLevel_update(tl,"leapfrog") + + call t_startf('prim_advance_exp') + + call set_prescribed_scm(elem, fvm, deriv, hvcoord, & + hybrid, dt, tl, nets, nete) + + call t_stopf('prim_advance_exp') + enddo + + end subroutine prim_step_scm !=======================================================================================================! @@ -718,4 +831,66 @@ subroutine get_global_ave_surface_pressure(elem, global_ave_ps_inic) deallocate(tmp) end subroutine get_global_ave_surface_pressure +subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & + hybrid, dt, tl, nets, nete) + use control_mod, only: tstep_type, qsplit + use derivative_mod, only: derivative_t + use dimensions_mod, only: np, nlev + use element_mod, only: element_t + use hybvcoord_mod, only: hvcoord_t + use hybrid_mod, only: hybrid_t + use time_mod, only: TimeLevel_t, timelevel_qdp, tevolve + use fvm_control_volume_mod, only: fvm_struct + use cam_thermo, only: get_kappa_dry + use air_composition, only: thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp + use physconst, only: cpair + implicit none + + type (element_t), intent(inout), target :: elem(:) + type(fvm_struct) , intent(inout) :: fvm(:) + type (derivative_t) , intent(in) :: deriv + type (hvcoord_t) :: hvcoord + type (hybrid_t) , intent(in) :: hybrid + real (kind=r8), intent(in) :: dt + type (TimeLevel_t) , intent(in) :: tl + integer , intent(in) :: nets + integer , intent(in) :: nete + + ! Local + integer :: ie,nm1,n0,np1,k,qn0,qnp1,m_cnst, nq,p + real(kind=r8) :: eta_dot_dpdn(np,np,nlev+1) + + + call t_startf('prim_advance_exp') + nm1 = tl%nm1 + n0 = tl%n0 + np1 = tl%np1 + + !!jt ie needs to be set correctly for IOP's and CAMIOP's + ie=35 + call TimeLevel_Qdp(tl, qsplit, qn0, qnp1) ! compute current Qdp() timelevel + + do k=1,nlev + eta_dot_dpdn(:,:,k)=elem(ie)%derived%omega(:,:,k) + enddo + eta_dot_dpdn(:,:,nlev+1) = eta_dot_dpdn(:,:,nlev) + + do k=1,nlev + elem(ie)%state%dp3d(:,:,k,np1) = elem(ie)%state%dp3d(:,:,k,n0) & + + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + enddo + + do k=1,nlev + elem(ie)%state%T(:,:,k,np1) = elem(ie)%state%T(:,:,k,n0) + enddo + + do p=1,qsize + do k=1,nlev + elem(ie)%state%Qdp(:,:,k,p,qnp1) = elem(ie)%state%Qdp(:,:,k,p,qn0) & + + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + enddo + enddo + end subroutine set_prescribed_scm + end module prim_driver_mod diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 6504eb75cd..81027b2efa 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -581,6 +581,10 @@ subroutine dyn_init(dyn_in, dyn_out) use air_composition, only: thermodynamic_active_species_liq_idx_dycore,thermodynamic_active_species_ice_idx_dycore use air_composition, only: thermodynamic_active_species_liq_num, thermodynamic_active_species_ice_num use cam_history, only: addfld, add_default, horiz_only, register_vector_field +#if (defined BFB_CAM_SCAM_IOP ) + use history_defaults, only: initialize_iop_history +#endif + use gravity_waves_sources, only: gws_init use thread_mod, only: horz_num_threads @@ -738,6 +742,10 @@ subroutine dyn_init(dyn_in, dyn_out) nullify(dyn_out%fvm) end if +#ifdef BFB_CAM_SCAM_IOP + call initialize_iop_history +#endif + call set_phis(dyn_in) if (initial_run) then @@ -931,11 +939,13 @@ subroutine dyn_init(dyn_in, dyn_out) do m = 1, pcnst call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(cnst_name(m))//' horz + vert', & gridname='FVM') + call add_default(tottnam(m), 2, ' ') end do else do m = 1, pcnst call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(cnst_name(m))//' horz + vert', & gridname='GLL') + call add_default(tottnam(m), 2, ' ') end do end if call phys_getopts(history_budget_out=history_budget, history_budget_histfile_num_out=budget_hfile_num) @@ -962,6 +972,8 @@ subroutine dyn_run(dyn_state) use control_mod, only: qsplit, rsplit, ftype_conserve use thread_mod, only: horz_num_threads use time_mod, only: tevolve + use scamMod, only: single_column, use_3dfrc + use se_single_column_mod, only: apply_SC_forcing type(dyn_export_t), intent(inout) :: dyn_state @@ -991,139 +1003,151 @@ subroutine dyn_run(dyn_state) if (iam >= par%nprocs) return - ldiag = hist_fld_active('ABS_dPSdt') - if (ldiag) then - allocate(ps_before(np,np,nelemd)) - allocate(abs_ps_tend(np,np,nelemd)) + if (.not. use_3dfrc) then - end if - - !$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(hybrid,nets,nete,n,ie,m,i,j,k,ftmp) - hybrid = config_thread_region(par,'horizontal') - call get_loop_ranges(hybrid, ibeg=nets, iend=nete) - - dtime = get_step_size() - rec2dt = 1._r8/dtime - - tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics - call TimeLevel_Qdp(TimeLevel, qsplit, n0_qdp)!get n0_qdp for diagnostics call - - ! output physics forcing - if (hist_fld_active('FU') .or. hist_fld_active('FV') .or.hist_fld_active('FT')) then - do ie = nets, nete - do k = 1, nlev - do j = 1, np - do i = 1, np - ftmp(i+(j-1)*np,k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) - ftmp(i+(j-1)*np,k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) - ftmp(i+(j-1)*np,k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) + ldiag = hist_fld_active('ABS_dPSdt') + if (ldiag) then + allocate(ps_before(np,np,nelemd)) + allocate(abs_ps_tend(np,np,nelemd)) + + end if + + !$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(hybrid,nets,nete,n,ie,m,i,j,k,ftmp) + hybrid = config_thread_region(par,'horizontal') + call get_loop_ranges(hybrid, ibeg=nets, iend=nete) + + dtime = get_step_size() + rec2dt = 1._r8/dtime + + tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics + call TimeLevel_Qdp(TimeLevel, qsplit, n0_qdp)!get n0_qdp for diagnostics call + + ! output physics forcing + if (hist_fld_active('FU') .or. hist_fld_active('FV') .or.hist_fld_active('FT')) then + do ie = nets, nete + do k = 1, nlev + do j = 1, np + do i = 1, np + ftmp(i+(j-1)*np,k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) + ftmp(i+(j-1)*np,k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) + ftmp(i+(j-1)*np,k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) + end do end do end do + + call outfld('FU', ftmp(:,:,1), npsq, ie) + call outfld('FV', ftmp(:,:,2), npsq, ie) + call outfld('FT', ftmp(:,:,3), npsq, ie) end do - - call outfld('FU', ftmp(:,:,1), npsq, ie) - call outfld('FV', ftmp(:,:,2), npsq, ie) - call outfld('FT', ftmp(:,:,3), npsq, ie) - end do - end if - - do m = 1, qsize - if (hist_fld_active('F'//trim(cnst_name_gll(m))//'_gll')) then - do ie = nets, nete - call outfld('F'//trim(cnst_name_gll(m))//'_gll',& - RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/)), npsq, ie) - end do - end if - end do - - - - ! convert elem(ie)%derived%fq to mass tendency - do ie = nets, nete + end if + do m = 1, qsize - do k = 1, nlev - do j = 1, np - do i = 1, np - dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & - rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) - end do + if (hist_fld_active('F'//trim(cnst_name_gll(m))//'_gll')) then + do ie = nets, nete + call outfld('F'//trim(cnst_name_gll(m))//'_gll',& + RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/)), npsq, ie) end do - end do + end if end do - end do - - - if (ftype_conserve>0) then - do ie = nets, nete - do k=1,nlev - do j=1,np - do i = 1, np - pdel = dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) - do nq=dry_air_species_num+1,thermodynamic_active_species_num - m_cnst = thermodynamic_active_species_idx_dycore(nq) - pdel = pdel + (dyn_state%elem(ie)%state%qdp(i,j,k,m_cnst,n0_qdp)+dyn_state%elem(ie)%derived%FQ(i,j,k,m_cnst)*dtime) - end do - dyn_state%elem(ie)%derived%FDP(i,j,k) = pdel - end do - end do - end do - end do - end if - - - if (use_cslam) then + + + + ! convert elem(ie)%derived%fq to mass tendency do ie = nets, nete - do m = 1, ntrac + do m = 1, qsize do k = 1, nlev - do j = 1, nc - do i = 1, nc - dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & - rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) + do j = 1, np + do i = 1, np + dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & + rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) end do end do end do end do end do - end if - - if (ldiag) then - abs_ps_tend(:,:,nets:nete) = 0.0_r8 - endif - - do n = 1, nsplit_local - - if (ldiag) then + + + if (ftype_conserve>0) then do ie = nets, nete - ps_before(:,:,ie) = dyn_state%elem(ie)%state%psdry(:,:) + do k=1,nlev + do j=1,np + do i = 1, np + pdel = dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + do nq=dry_air_species_num+1,thermodynamic_active_species_num + m_cnst = thermodynamic_active_species_idx_dycore(nq) + pdel = pdel + (dyn_state%elem(ie)%state%qdp(i,j,k,m_cnst,n0_qdp)+dyn_state%elem(ie)%derived%FQ(i,j,k,m_cnst)*dtime) + end do + dyn_state%elem(ie)%derived%FDP(i,j,k) = pdel + end do + end do + end do end do end if - - ! forward-in-time RK, with subcycling - call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets, nete, & - tstep, TimeLevel, hvcoord, n, omega_cn) - - if (ldiag) then + + + if (use_cslam) then do ie = nets, nete - abs_ps_tend(:,:,ie) = abs_ps_tend(:,:,ie) + & - ABS(ps_before(:,:,ie)-dyn_state%elem(ie)%state%psdry(:,:)) & - /(tstep*qsplit*rsplit) + do m = 1, ntrac + do k = 1, nlev + do j = 1, nc + do i = 1, nc + dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & + rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) + end do + end do + end do + end do end do end if + + + + if (ldiag) then + abs_ps_tend(:,:,nets:nete) = 0.0_r8 + endif + + do n = 1, nsplit_local + + if (ldiag) then + do ie = nets, nete + ps_before(:,:,ie) = dyn_state%elem(ie)%state%psdry(:,:) + end do + end if + + ! forward-in-time RK, with subcycling + call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets, nete, & + tstep, TimeLevel, hvcoord, n, single_column, omega_cn) + + if (ldiag) then + do ie = nets, nete + abs_ps_tend(:,:,ie) = abs_ps_tend(:,:,ie) + & + ABS(ps_before(:,:,ie)-dyn_state%elem(ie)%state%psdry(:,:)) & + /(tstep*qsplit*rsplit) + end do + end if + + end do + + if (ldiag) then + do ie=nets,nete + abs_ps_tend(:,:,ie)=abs_ps_tend(:,:,ie)/DBLE(nsplit) + call outfld('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/)),npsq,ie) + end do + end if + + !$OMP END PARALLEL - end do + if (ldiag) then + deallocate(ps_before,abs_ps_tend) + endif - if (ldiag) then - do ie=nets,nete - abs_ps_tend(:,:,ie)=abs_ps_tend(:,:,ie)/DBLE(nsplit) - call outfld('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/)),npsq,ie) - end do end if - !$OMP END PARALLEL - if (ldiag) then - deallocate(ps_before,abs_ps_tend) - endif + if (single_column) then + call apply_SC_forcing(dyn_state%elem,hvcoord,TimeLevel,3,.false.,nets,nete) + end if + ! output vars on CSLAM fvm grid call write_dyn_vars(dyn_state) diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 new file mode 100644 index 0000000000..96c3febefe --- /dev/null +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -0,0 +1,337 @@ +module se_single_column_mod +!-------------------------------------------------------- +! +! Module for the SE single column model + +use shr_kind_mod, only: r8=>shr_kind_r8 +use element_mod, only: element_t +use scamMod, only: have_t, have_q, have_u, have_v, have_ps, have_numliq, & + have_cldliq, have_numice, have_cldice, have_omega, use_camiop, & + tobs, qobs,have_numliq, numliqobs, cldliqobs, numiceobs, cldiceobs, & + wfld, psobs,uobs,vobs,tobs,divt,divQ,divT3d,divq3d,precobs,lhflxobs, & + shflxobs, tground, have_ps, have_tg, have_lhflx, have_shflx, have_t, & + have_omega, have_cldliq, have_divt, have_divq, have_divt3d, have_divq3d, & + use_3dfrc +use constituents, only: cnst_get_ind, pcnst +use dimensions_mod, only: nelemd, np, nlev +use time_manager, only: get_nstep, is_first_step, get_step_size, is_first_restart_step +use ppgrid, only: begchunk +use time_mod, only: timelevel_qdp +use cam_history, only: outfld + +implicit none + +private +save + +public scm_setinitial +public scm_setfield +public apply_SC_forcing +public iop_broadcast + +integer :: tl_f, tl_fqdp + +!========================================================================= +contains +!========================================================================= + +subroutine scm_setinitial(elem) + + use constituents, only: qmin + use dyn_grid, only: TimeLevel + use control_mod, only: qsplit + + implicit none + + type(element_t), intent(inout) :: elem(:) + + integer i, j, k, cix, ie, thelev + integer inumliq, inumice, icldliq, icldice + integer :: tl_f, tl_fqdp + + tl_f = timelevel%n0 + call TimeLevel_Qdp(timelevel, qsplit, tl_fqdp) + + if (.not. use_camiop .and. get_nstep() .eq. 0) then + call cnst_get_ind('NUMLIQ', inumliq, abort=.false.) + call cnst_get_ind('NUMICE', inumice, abort=.false.) + call cnst_get_ind('CLDLIQ', icldliq) + call cnst_get_ind('CLDICE', icldice) + + do ie=1,nelemd + do j=1,np + do i=1,np + + ! Find level where tobs is no longer zero + thelev=1 + do k=1, NLEV + if (tobs(k) .ne. 0) then + thelev=k + go to 1000 + endif + enddo + +1000 continue + + if (get_nstep() .le. 1) then + do k=1,thelev-1 + tobs(k)=elem(ie)%state%T(i,j,k,tl_f) + qobs(k)=elem(ie)%state%qdp(i,j,k,1,tl_fqdp)/elem(ie)%state%dp3d(i,j,k,tl_f) + enddo + else + tobs(:)=elem(ie)%state%T(i,j,:,tl_f) + qobs(:)=elem(ie)%state%qdp(i,j,:,1,tl_fqdp)/elem(ie)%state%dp3d(i,j,:,tl_f) + endif + + if (get_nstep() .eq. 0) then + do cix = 1, pcnst +!jt if (scm_zero_non_iop_tracers) elem(ie)%state%qdp(i,j,:,cix,tl_qdp_np0) = qmin(cix)*elem(ie)%state%dp3d(i,j,:,tl_qdp_np0) + elem(ie)%state%qdp(i,j,:,cix,tl_fqdp) = qmin(cix)*elem(ie)%state%dp3d(i,j,:,tl_f) + end do + do k=thelev, NLEV + if (have_t) elem(ie)%state%T(i,j,k,tl_f)=tobs(k) + if (have_q) elem(ie)%state%qdp(i,j,k,1,tl_fqdp)=qobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) +!jt if (have_q) elem(ie)%state%qdp(i,j,k,1,tl_f)=qobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) + + enddo + + do k=1,NLEV + if (have_ps) elem(ie)%state%psdry(i,j) = psobs + if (have_u) elem(ie)%state%v(i,j,1,k,tl_f) = uobs(k) + if (have_v) elem(ie)%state%v(i,j,2,k,tl_f) = vobs(k) + if (have_numliq) elem(ie)%state%qdp(i,j,k,inumliq,tl_fqdp) = numliqobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) + if (have_cldliq) elem(ie)%state%qdp(i,j,k,icldliq,tl_fqdp) = cldliqobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) + if (have_numice) elem(ie)%state%qdp(i,j,k,inumice,tl_fqdp) = numiceobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) + if (have_cldice) elem(ie)%state%qdp(i,j,k,icldice,tl_fqdp) = cldiceobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) + if (have_omega) elem(ie)%derived%omega(i,j,k) = wfld(k) + enddo + + endif + + enddo + enddo + enddo + endif + +end subroutine scm_setinitial + +subroutine scm_setfield(elem,iop_update_phase1) + +!--------------------------------------------------------- +! Purpose: Update various fields based on available data +! provided by IOP file +!---------------------------------------------------------- + + implicit none + + logical, intent(in) :: iop_update_phase1 + type(element_t), intent(inout) :: elem(:) + + integer i, j, k, ie + + do ie=1,nelemd + if (have_ps .and. use_camiop .and. .not. iop_update_phase1) elem(ie)%state%psdry(:,:) = psobs + if (have_ps .and. .not. use_camiop) elem(ie)%state%psdry(:,:) = psobs + do i=1, NLEV + if (have_omega .and. iop_update_phase1) elem(ie)%derived%omega(:,:,i)=wfld(i) ! set t to tobs at first + end do + end do + +end subroutine scm_setfield + +subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) +! + use scamMod, only: single_column, use_3dfrc + use dimensions_mod, only : np, nlev, npsq,qsize_d + + use hybvcoord_mod, only : hvcoord_t + use element_mod, only : element_t + use physconst, only: rair + use time_mod + use time_manager, only: get_nstep + use shr_const_mod, only: SHR_CONST_PI + use control_mod, only: qsplit + use apply_iop_forcing_mod, only:advance_iop_forcing, advance_iop_nudging + + integer :: n,nets,nete + type (element_t) , intent(inout), target :: elem(:) + type (hvcoord_t) :: hvcoord + type (TimeLevel_t), intent(in) :: tl + logical :: t_before_advance + + integer :: tl_qdp_np0,tl_qdp_np1 + integer :: ie,k,i,j,t,ii,jj,m + real (r8), dimension(nlev) :: p + real (r8) ::dt + + integer ::nelemd_todo, np_todo + logical ::scm_multcols = .false. + logical ::iop_nudge_tq = .false. + real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update + real (r8), dimension(nlev) :: temp_tend, t_update, u_update, v_update + real (r8), dimension(nlev) :: t_in, u_in, v_in + real (r8), dimension(nlev) :: relaxt, relaxq + real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn + real (r8), dimension(npsq,nlev) :: tdiff_out, qdiff_out + real (r8) :: dpscm(nlev) + +!----------------------------------------------------------------------- + + tl_f = tl%n0 + + call TimeLevel_Qdp(tl, qsplit, tl_fqdp) + + ! For SCM only one column is considered + ie = 35 + ii=3 + jj=4 + + ! Settings for traditional SCM run + nelemd_todo = 1 + np_todo = 1 + + if (scm_multcols) then + nelemd_todo = nelemd + np_todo = np + endif + + do k=1,nlev + p(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*elem(ie)%state%psdry(ii,jj) + dpscm(k) = elem(ie)%state%dp3d(ii,jj,k,tl_f) + end do + + dt = get_step_size() + + ! Set initial profiles for current column + do m=1,pcnst + stateQ_in(:nlev,m) = elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/dpscm(:nlev) + end do + t_in(:nlev) = elem(ie)%state%T(ii,jj,:nlev,tl_f) + u_in(:nlev) = elem(ie)%state%v(ii,jj,1,:nlev,tl_f) + v_in(:nlev) = elem(ie)%state%v(ii,jj,2,:nlev,tl_f) + + if (.not. use_3dfrc ) then + temp_tend(:) = 0.0_r8 + else + temp_tend(:) = elem(ie)%derived%fT(i,j,:) + endif + + ! Call the main subroutine to update t, q, u, and v according to + ! large scale forcing as specified in IOP file. + call advance_iop_forcing(dt,elem(ie)%state%psdry(ii,jj),& ! In + u_in,v_in,t_in,stateQ_in,temp_tend, hvcoord, & ! In + u_update,v_update,t_update,q_update) ! Out + + ! Nudge to observations if desired, for T & Q only if in SCM mode + if (iop_nudge_tq .and. .not. scm_multcols) then + call advance_iop_nudging(dt,elem(ie)%state%psdry(ii,jj),& ! In + t_update,q_update(:,1), hvcoord, & ! Inn + t_update,q_update(:,1),relaxt,relaxq) ! Out + endif + + ! Update the q related arrays. NOTE that Qdp array must + ! be updated first to ensure exact restarts + do m=1,pcnst + ! Update the Qdp array + elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp) = & + q_update(:nlev,m) * dpscm(:nlev) + ! Update the Q array +!jt elem(ie)%state%Q(ii,jj,:nlev,m) = & +!jt elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/dpscm(:nlev) + enddo + + ! Update prognostic variables to the current values + elem(ie)%state%T(ii,jj,:,tl_f) = t_update(:) + elem(ie)%state%v(ii,jj,1,:,tl_f) = u_update(:) + elem(ie)%state%v(ii,jj,2,:,tl_f) = v_update(:) + + ! Evaluate the differences in state information from observed + ! (done for diganostic purposes only) + do k = 1, nlev + tdiff_dyn(k) = t_update(k) - tobs(k) + qdiff_dyn(k) = q_update(k,1) - qobs(k) + end do + + ! Add various diganostic outfld calls + + if (scm_multcols) then + do i=1,np + do j=1,np + tdiff_out(i+(j-1)*np,:)=tdiff_dyn(:) + qdiff_out(i+(j-1)*np,:)=qdiff_dyn(:) + end do + end do + call outfld('TDIFF',tdiff_out,npsq,ie) + call outfld('QDIFF',qdiff_out,npsq,ie) + else + call outfld('TDIFF',tdiff_dyn,1,begchunk) + call outfld('QDIFF',qdiff_dyn,1,begchunk) + endif + + call outfld('TOBS',tobs,1,begchunk) + call outfld('QOBS',qobs,1,begchunk) + call outfld('DIVQ',divq,1,begchunk) + call outfld('DIVT',divt,1,begchunk) + call outfld('DIVQ3D',divq3d,1,begchunk) + call outfld('DIVT3D',divt3d,1,begchunk) + call outfld('PRECOBS',precobs,1,begchunk) + call outfld('LHFLXOBS',lhflxobs,1,begchunk) + call outfld('SHFLXOBS',shflxobs,1,begchunk) + + call outfld('TRELAX',relaxt,1,begchunk) + call outfld('QRELAX',relaxq,1,begchunk) + + + end subroutine apply_SC_forcing +!========================================================================= + subroutine iop_broadcast() + + !--------------------------------------------------------- + ! Purpose: When running DP-CRM, broadcast relevant logical + ! flags and data to all processors + !---------------------------------------------------------- + + use spmd_utils, only: mpi_logical, mpi_real8, masterproc, iam, mpicom, mstrid=>masterprocid + use dimensions_mod, only: nlev + + integer :: ierr +#ifdef SPMD + + call mpi_bcast(have_ps,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_tg,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_lhflx,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_shflx,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_t,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_q,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_u,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_v,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_omega,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_cldliq,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_divt,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_divq,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_divt3d,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(have_divq3d,1,mpi_logical,mstrid,mpicom,ierr) + call mpi_bcast(use_3dfrc,1,mpi_logical,mstrid,mpicom,ierr) + + call mpi_bcast(psobs,1,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(tground,1,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(lhflxobs,1,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(shflxobs,1,mpi_real8,mstrid,mpicom,ierr) + + call mpi_bcast(tobs,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(qobs,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(uobs,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(vobs,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(cldliqobs,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(wfld,nlev,mpi_real8,mstrid,mpicom,ierr) + + call mpi_bcast(divt,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(divq,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(divt3d,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(divq3d,nlev,mpi_real8,mstrid,mpicom,ierr) + +#endif + + end subroutine iop_broadcast + + end module se_single_column_mod diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index 88dda66c3d..75b3b62018 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -1,7 +1,7 @@ module stepon use shr_kind_mod, only: r8 => shr_kind_r8 -use spmd_utils, only: iam, mpicom +use spmd_utils, only: iam, mpicom, masterproc use ppgrid, only: begchunk, endchunk use physics_types, only: physics_state, physics_tend @@ -11,11 +11,16 @@ module stepon use cam_abortutils, only: endrun use parallel_mod, only: par -use dimensions_mod, only: nelemd +use dimensions_mod, only: np, npsq, nlev, qsize_d, nelemd use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state use microp_aero, only: aerosol_state_object, aerosol_properties_object +use scamMod, only: use_iop, doiopupdate, single_column, & + setiopupdate, setiopupdate_init, readiopdata +use se_single_column_mod, only: scm_setfield, scm_setinitial, iop_broadcast +use dyn_grid, only: hvcoord +use time_manager, only: get_step_size, is_last_step, is_first_step, is_first_restart_step implicit none private @@ -29,6 +34,7 @@ module stepon class(aerosol_properties), pointer :: aero_props_obj => null() logical :: aerosols_transported = .false. +logical :: iop_update_phase1 !========================================================================================= contains @@ -95,7 +101,6 @@ end subroutine stepon_init subroutine stepon_run1( dtime_out, phys_state, phys_tend, & pbuf2d, dyn_in, dyn_out ) - use time_manager, only: get_step_size use dp_coupling, only: d_p_coupling use physics_buffer, only: physics_buffer_desc @@ -109,7 +114,7 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & type (physics_buffer_desc), pointer :: pbuf2d(:,:) !---------------------------------------------------------------------------- - integer :: c + integer :: c class(aerosol_state), pointer :: aero_state_obj nullify(aero_state_obj) @@ -122,7 +127,38 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & ! write diagnostic fields on gll grid and initial file call diag_dynvar_ic(dyn_out%elem, dyn_out%fvm) end if + + ! Determine whether it is time for an IOP update; + ! doiopupdate set to true if model time step > next available IOP + + + if (use_iop .and. masterproc) then + if (is_first_step()) then + call setiopupdate_init() + else + call setiopupdate + endif + end if + if (single_column) then + + ! If first restart step then ensure that IOP data is read + if (is_first_restart_step()) then + iop_update_phase1 = .false. + call scm_setinitial(dyn_out%elem) + if (masterproc) call readiopdata( iop_update_phase1,hvcoord ) + call iop_broadcast() + endif + + iop_update_phase1 = .true. + if ((is_first_restart_step() .or. doiopupdate) .and. masterproc) then + call readiopdata(iop_update_phase1,hvcoord) + endif + call iop_broadcast() + + call scm_setfield(dyn_out%elem,iop_update_phase1) + endif + call t_barrierf('sync_d_p_coupling', mpicom) call t_startf('d_p_coupling') ! Move data into phys_state structure. @@ -209,6 +245,10 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) use dyn_grid, only: TimeLevel use time_mod, only: TimeLevel_Qdp use control_mod, only: qsplit + use constituents, only: pcnst, cnst_name + use cam_history, only: outfld + use time_manager, only: is_first_step + ! arguments real(r8), intent(in) :: dtime ! Time-step type(cam_out_t), intent(inout) :: cam_out(:) ! Output from CAM to surface @@ -217,11 +257,50 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container integer :: tl_f, tl_fQdp + integer :: rc, i, j, k, p, ie +#if defined (BFB_CAM_SCAM_IOP) + real(r8) :: forcing_temp(npsq,nlev), forcing_q(npsq,nlev,pcnst) + real(r8) :: ftmp_temp(np,np,nlev,nelemd), ftmp_q(np,np,nlev,pcnst,nelemd) + real(r8) :: out_temp(npsq,nlev), out_q(npsq,nlev), out_u(npsq,nlev), & + out_v(npsq,nlev), out_psv(npsq) +#endif !-------------------------------------------------------------------------------------- call t_startf('comp_adv_tends1') tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) + +#if (defined BFB_CAM_SCAM_IOP) + + tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics + + ! Save ftmp stuff to get state before dynamics is called + do ie=1,nelemd + ftmp_temp(:,:,:,ie) = dyn_in%elem(ie)%state%T(:,:,:,tl_f) + do p = 1, qsize_d + ftmp_q(:,:,:,p,ie) = dyn_in%elem(ie)%state%Qdp(:,:,:,p,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(:,:,:,tl_f) + enddo + enddo +#endif + + if (single_column) then + + ! Update IOP properties e.g. omega, divT, divQ + + if (.not. is_first_step()) iop_update_phase1 = .false. +!jt e3sm has this iop_update_phase1 = .false. + if (doiopupdate) then + call scm_setinitial(dyn_out%elem) + if (masterproc) call readiopdata(iop_update_phase1,hvcoord) + call iop_broadcast() + call scm_setfield(dyn_out%elem,iop_update_phase1) + endif + endif + + call t_startf('comp_adv_tends1') + tl_f = TimeLevel%n0 + call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) call t_stopf('comp_adv_tends1') @@ -236,6 +315,52 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) call t_stopf('comp_adv_tends2') + ! Update to get tendency +#if (defined BFB_CAM_SCAM_IOP) + + tl_f = TimeLevel%n0 + + do ie=1,nelemd + do k=1,nlev + do j=1,np + do i=1,np + + ! Note that this calculation will not provide b4b results with + ! an E3SM because the dynamics tendency is not computed in the exact + ! same way as an E3SM run, introducing error with roundoff + forcing_temp(i+(j-1)*np,k) = (dyn_in%elem(ie)%state%T(i,j,k,tl_f) - & + ftmp_temp(i,j,k,ie))/dtime - dyn_in%elem(ie)%derived%FT(i,j,k) + out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) + out_u(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,1,k,tl_f) + out_v(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,2,k,tl_f) + out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) + out_psv(i+(j-1)*np) = dyn_in%elem(ie)%state%psdry(i,j) + + do p=1,qsize_d + forcing_q(i+(j-1)*np,k,p) = (dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - & + ftmp_q(i,j,k,p,ie))/dtime + enddo + + enddo + enddo + enddo + + call outfld('Ps',out_psv,npsq,ie) + call outfld('t',out_temp,npsq,ie) + call outfld('q',out_q,npsq,ie) + call outfld('u',out_u,npsq,ie) + call outfld('v',out_v,npsq,ie) + call outfld('divT3d',forcing_temp,npsq,ie) + do p=1,qsize_d + call outfld(trim(cnst_name(p))//'_dten',forcing_q(:,:,p),npsq,ie) + enddo + + enddo + +#endif + end subroutine stepon_run3 !========================================================================================= diff --git a/src/infrastructure/phys_grid.F90 b/src/infrastructure/phys_grid.F90 index 3426c86f27..203ce4e583 100644 --- a/src/infrastructure/phys_grid.F90 +++ b/src/infrastructure/phys_grid.F90 @@ -63,6 +63,7 @@ module phys_grid ! The identifier for the physics grid integer, parameter, public :: phys_decomp = 100 + integer, parameter, public :: phys_decomp_scm = 110 !! PUBLIC TYPES @@ -119,6 +120,7 @@ module phys_grid integer, protected, public :: index_bottom_layer = 0 integer, protected, public :: index_top_interface = 1 integer, protected, public :: index_bottom_interface = 0 + integer, public :: phys_columns_on_task = 0 !============================================================================== CONTAINS @@ -191,6 +193,8 @@ subroutine phys_grid_init() use cam_grid_support, only: horiz_coord_t, horiz_coord_create use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists use shr_const_mod, only: PI => SHR_CONST_PI + use scamMod, only: scmlon,scmlat,single_column + use cam_grid_support, only: max_hcoordname_len ! Local variables integer :: index @@ -203,6 +207,7 @@ subroutine phys_grid_init() real(r8), pointer :: latvals(:) real(r8) :: lonmin, latmin integer(iMap), pointer :: grid_map(:,:) + integer(iMap), pointer :: grid_map_scm(:,:) integer(iMap), allocatable :: coord_map(:) type(horiz_coord_t), pointer :: lat_coord type(horiz_coord_t), pointer :: lon_coord @@ -217,6 +222,9 @@ subroutine phys_grid_init() character(len=hclen) :: copy_gridname character(len=*), parameter :: subname = 'phys_grid_init: ' real(r8), parameter :: rarea_sphere = 1.0_r8 / (4.0_r8*PI) + real (r8), allocatable :: dynlats(:),dynlons(:),pos_dynlons(:) + real (r8) :: pos_scmlon,minpoint,testpoint + integer :: scm_col_index, i nullify(lonvals) nullify(latvals) @@ -237,6 +245,36 @@ subroutine phys_grid_init() ! Gather info from the dycore call get_dyn_grid_info(hdim1_d, hdim2_d, pver, index_top_layer, & index_bottom_layer, unstructured, dyn_columns) + + ! Set up the physics decomposition + columns_on_task = size(dyn_columns) + + if (single_column) then + allocate(dynlats(columns_on_task),dynlons(columns_on_task),pos_dynlons(columns_on_task)) + dynlats(:) = dyn_columns(:)%lat_deg + dynlons(:) = dyn_columns(:)%lon_deg + + pos_dynlons(:)= mod(dynlons(:) + 360._r8,360._r8) + pos_scmlon = mod(scmlon + 360._r8,360._r8) + + if (unstructured) then + minpoint=1000.0 + do i=1,columns_on_task + testpoint=abs(pos_dynlons(i)-pos_scmlon)+abs(dynlats(i)-scmlat) + if (testpoint .lt. minpoint) then + minpoint=testpoint + scm_col_index=i + endif + enddo + end if + hdim1_d = 1 + hdim2_d = 1 + phys_columns_on_task = 1 + deallocate(dynlats,dynlons,pos_dynlons) + else + phys_columns_on_task = columns_on_task + end if + ! hdim1_d * hdim2_d is the total number of columns num_global_phys_cols = hdim1_d * hdim2_d pverp = pver + 1 @@ -251,14 +289,12 @@ subroutine phys_grid_init() index_top_interface = index_top_layer + 1 end if - ! Set up the physics decomposition - columns_on_task = size(dyn_columns) if (allocated(phys_columns)) then deallocate(phys_columns) end if - allocate(phys_columns(columns_on_task)) - if (columns_on_task > 0) then - col_index = columns_on_task + allocate(phys_columns(phys_columns_on_task)) + if (phys_columns_on_task > 0) then + col_index = phys_columns_on_task num_chunks = col_index / pcols if ((num_chunks * pcols) < col_index) then num_chunks = num_chunks + 1 @@ -273,21 +309,30 @@ subroutine phys_grid_init() col_index = 0 ! Simple chunk assignment do index = begchunk, endchunk - chunks(index)%ncols = MIN(pcols, (columns_on_task - col_index)) + chunks(index)%ncols = MIN(pcols, (phys_columns_on_task - col_index)) chunks(index)%chunk_index = index allocate(chunks(index)%phys_cols(chunks(index)%ncols)) do phys_col = 1, chunks(index)%ncols col_index = col_index + 1 ! Copy information supplied by the dycore - phys_columns(col_index) = dyn_columns(col_index) + if (single_column) then + + phys_columns(col_index) = dyn_columns(scm_col_index) + !single column only has 1 global column that is written to at offset 1 + phys_columns(col_index)%global_col_num = 1 + else + phys_columns(col_index) = dyn_columns(col_index) + end if ! Fill in physics decomp info +!jt phys_columns(col_index)%coord_indices(:)=scm_col_index + phys_columns(col_index)%coord_indices(:)=1 phys_columns(col_index)%phys_task = iam phys_columns(col_index)%local_phys_chunk = index phys_columns(col_index)%phys_chunk_index = phys_col chunks(index)%phys_cols(phys_col) = col_index end do end do - + deallocate(dyn_columns) ! Add physics-package grid to set of CAM grids @@ -414,7 +459,7 @@ subroutine phys_grid_init() ! (Note, a separate physics grid is only supported for ! unstructured grids). allocate(area_d(size(grid_map, 2))) - do col_index = 1, columns_on_task + do col_index = 1, phys_columns_on_task area_d(col_index) = phys_columns(col_index)%area end do call cam_grid_attribute_register('physgrid', 'area', & @@ -422,7 +467,7 @@ subroutine phys_grid_init() nullify(area_d) ! Belongs to attribute now allocate(areawt_d(size(grid_map, 2))) - do col_index = 1, columns_on_task + do col_index = 1, phys_columns_on_task areawt_d(col_index) = phys_columns(col_index)%weight*rarea_sphere end do call cam_grid_attribute_register('physgrid', 'areawt', & @@ -433,17 +478,86 @@ subroutine phys_grid_init() end if end if ! Cleanup pointers (they belong to the grid now) - nullify(grid_map) - deallocate(latvals) - nullify(latvals) - deallocate(lonvals) - nullify(lonvals) +!jt nullify(grid_map) ! Cleanup, we are responsible for copy attributes if (associated(copy_attributes)) then deallocate(copy_attributes) nullify(copy_attributes) end if + ! if running single_column physgrid can map between a full grid boundary file + ! and the single column physics - To write to a single column history file + ! we need an additional grid that does not include the dynamics offset of the full grid. + if (single_column) then + ! First, create a map for the physics grid + ! It's structure will depend on whether or not the physics grid is + ! unstructured + if (unstructured) then + allocate(grid_map_scm(3, pcols * (endchunk - begchunk + 1))) + else + allocate(grid_map_scm(4, pcols * (endchunk - begchunk + 1))) + end if + ! new grid matches physgrid with the exception of file index which points to the column on the full grid + grid_map_scm = grid_map + grid_map_scm(3, 1) = int(scm_col_index, iMap) + + if (unstructured) then + ! lonvals/latvals calculated above + lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & + 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & + map=grid_map_scm(3,:)) + lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & + 'latitude', 'degrees_north', 1, size(latvals), latvals, & + map=grid_map_scm(3,:)) + else + allocate(coord_map(size(grid_map_scm, 2))) + ! We need a global minimum longitude and latitude + if (npes > 1) then + temp = lonmin + call MPI_allreduce(temp, lonmin, 1, MPI_INTEGER, MPI_MIN, & + mpicom, ierr) + temp = latmin + call MPI_allreduce(temp, latmin, 1, MPI_INTEGER, MPI_MIN, & + mpicom, ierr) + ! Create lon coord map which only writes from one of each unique lon + where(latvals == latmin) + coord_map(:) = grid_map_scm(3, :) + elsewhere + coord_map(:) = 0_iMap + end where + lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, & + 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & + map=coord_map) + + ! Create lat coord map which only writes from one of each unique lat + where(lonvals == lonmin) + coord_map(:) = grid_map_scm(4, :) + elsewhere + coord_map(:) = 0_iMap + end where + lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, & + 'latitude', 'degrees_north', 1, size(latvals), latvals, & + map=coord_map) + deallocate(coord_map) + end if + end if + call cam_grid_register('physgrid_scm', phys_decomp_scm, lat_coord, lon_coord, & + grid_map_scm, unstruct=unstructured, block_indexed=.true.) + ! Copy required attributes from the dynamics array + nullify(copy_attributes) + call physgrid_copy_attributes_d(copy_gridname, copy_attributes) + do index = 1, size(copy_attributes) + call cam_grid_attribute_copy(copy_gridname, 'physgrid_scm', & + copy_attributes(index)) + end do + end if + nullify(grid_map) + nullify(grid_map_scm) + deallocate(latvals) + nullify(latvals) + deallocate(lonvals) + nullify(lonvals) + ! Set flag indicating physics grid is now set phys_grid_set = .true. @@ -526,7 +640,7 @@ end function phys_grid_initialized !======================================================================== integer function get_nlcols_p() - get_nlcols_p = columns_on_task + get_nlcols_p = phys_columns_on_task end function get_nlcols_p !======================================================================== diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 580ffdf67f..5afd2e0d25 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -1798,6 +1798,8 @@ subroutine diag_surf (cam_in, cam_out, state, pbuf) call outfld('shflx ',cam_in%shf, pcols, lchnk) call outfld('lhflx ',cam_in%lhf, pcols, lchnk) call outfld('trefht ',cam_in%tref, pcols, lchnk) + call outfld('Tg', cam_in%ts, pcols, lchnk) + call outfld('Tsair',cam_in%ts, pcols, lchnk) #endif ! ! Ouput ocn and ice fractions diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 7615f0e432..049db36fc7 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -31,7 +31,9 @@ module check_energy use constituents, only: cnst_get_ind, pcnst, cnst_name, cnst_get_type_byind use time_manager, only: is_first_step use cam_logfile, only: iulog - + use scamMod, only: single_column, use_camiop, heat_glob_scm + use cam_history, only: outfld + implicit none private @@ -587,8 +589,11 @@ subroutine check_energy_fix(state, ptend, nstep, eshflx) !---------------------------Local storage------------------------------- integer :: i ! column integer :: ncol ! number of atmospheric columns in chunk + integer :: lchnk ! chunk number + real(r8) :: heat_out(pcols) !----------------------------------------------------------------------- - ncol = state%ncol + lchnk = state%lchnk + ncol = state%ncol call physics_ptend_init(ptend, state%psetcols, 'chkenergyfix', ls=.true.) @@ -596,9 +601,28 @@ subroutine check_energy_fix(state, ptend, nstep, eshflx) ! disable the energy fix for offline driver heat_glob = 0._r8 #endif +! add (-) global mean total energy difference as heating + if (single_column .and. use_camiop) then + heat_glob = heat_glob_scm(1) + endif + + ! In single column model we do NOT want to take into + ! consideration the dynamics energy fixer. Since only + ! one column of dynamics is active, this data will + ! essentially be garbage. + if (single_column .and. .not. use_camiop) then + heat_glob = 0._r8 + endif ! add (-) global mean total energy difference as heating ptend%s(:ncol,:pver) = heat_glob +#if ( defined BFB_CAM_SCAM_IOP ) + if (nstep > 0) then + heat_out(:ncol) = heat_glob + call outfld('heat_glob', heat_out(:ncol), pcols, lchnk) + endif +#endif + ! compute effective sensible heat flux do i = 1, ncol eshflx(i) = heat_glob * (state%pint(i,pver+1) - state%pint(i,1)) * rga diff --git a/src/physics/cam/chem_surfvals.F90 b/src/physics/cam/chem_surfvals.F90 index 812ddc8fcd..4123753e32 100644 --- a/src/physics/cam/chem_surfvals.F90 +++ b/src/physics/cam/chem_surfvals.F90 @@ -264,7 +264,6 @@ subroutine chem_surfvals_init() use infnan, only: posinf, assignment(=) use mo_flbc, only: flbc_inti use phys_control, only: use_simple_phys - !---------------------------Local variables----------------------------- integer :: yr, mon, day, ncsec character(len=*), parameter :: sub = 'chem_surfvals_init' @@ -328,7 +327,6 @@ subroutine chem_surfvals_init() ! set by lower boundary conditions file call flbc_inti( flbc_file, flbc_list, flbc_timing, co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) call chem_surfvals_set() - endif if (masterproc) then @@ -512,6 +510,7 @@ subroutine chem_surfvals_set() use ppgrid, only: begchunk, endchunk use mo_flbc, only: flbc_gmean_vmr, flbc_chk + use scamMod, only: single_column, scmiop_flbc_inti !---------------------------Local variables----------------------------- @@ -527,7 +526,12 @@ subroutine chem_surfvals_set() elseif (scenario_ghg == 'CHEM_LBC_FILE') then ! set mixing ratios from cam-chem/waccm lbc file call flbc_chk() - call flbc_gmean_vmr(co2vmr,ch4vmr,n2ovmr,f11vmr,f12vmr) + if (single_column) then + call scmiop_flbc_inti( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) + else + ! set by lower boundary conditions file + call flbc_gmean_vmr(co2vmr,ch4vmr,n2ovmr,f11vmr,f12vmr) + endif endif if (masterproc .and. is_end_curr_day()) then diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 8a9c35bfd2..1402bf7fc9 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -2598,16 +2598,16 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Define the grid box size. CLUBB needs this information to determine what ! the maximum length scale should be. This depends on the column for ! variable mesh grids and lat-lon grids - if (single_column) then - ! If single column specify grid box size to be something - ! similar to a GCM run - grid_dx(:) = 100000._r8 - grid_dy(:) = 100000._r8 - else +!!$ if (single_column) then +!!$ ! If single column specify grid box size to be something +!!$ ! similar to a GCM run +!!$ grid_dx(:) = 100000._r8 +!!$ grid_dy(:) = 100000._r8 +!!$ else call grid_size(state1, grid_dx, grid_dy) - end if +!!$ end if if (clubb_do_icesuper) then diff --git a/src/physics/cam/phys_grid.F90 b/src/physics/cam/phys_grid.F90 index ca1670e4c2..f737c835de 100644 --- a/src/physics/cam/phys_grid.F90 +++ b/src/physics/cam/phys_grid.F90 @@ -1,4840 +1,1206 @@ module phys_grid -!----------------------------------------------------------------------- -! -! Purpose: Definition of physics computational horizontal grid. -! -! Method: Variables are private; interface routines used to extract -! information for use in user code. -! -! Entry points: -! phys_grid_readnl read namelist options -! -! phys_grid_init initialize chunk'ed data structure -! phys_grid_initialized get physgrid_set flag -! -! get_chunk_indices_p get local chunk index range -! get_ncols_p get number of columns for a given chunk -! get_grid_dims return physics grid axis global sizes -! get_xxx_all_p get global indices, coordinates, or values -! for a given chunk -! get_xxx_vec_p get global indices, coordinates, or values -! for a subset of the columns in a chunk -! get_xxx_p get global indices, coordinates, or values -! for a single column -! where xxx is -! area for column surface area (in radians squared) -! gcol for global column index -! lat for global latitude index -! lon for global longitude index -! rlat for latitude coordinate (in radians) -! rlon for longitude coordinate (in radians) -! wght for column integration weight -! -! scatter_field_to_chunk -! distribute field -! to decomposed chunk data structure -! gather_chunk_to_field -! reconstruct field -! from decomposed chunk data structure -! -! read_chunk_from_field -! read and distribute field -! to decomposed chunk data structure -! write_field_from_chunk -! write field -! from decomposed chunk data structure -! -! block_to_chunk_send_pters -! return pointers into send buffer where data -! from decomposed fields should -! be copied to -! block_to_chunk_recv_pters -! return pointers into receive buffer where data -! for decomposed chunk data structures should -! be copied from -! transpose_block_to_chunk -! transpose buffer containing decomposed -! fields to buffer -! containing decomposed chunk data structures -! -! chunk_to_block_send_pters -! return pointers into send buffer where data -! from decomposed chunk data structures should -! be copied to -! chunk_to_block_recv_pters -! return pointers into receive buffer where data -! for decomposed fields should -! be copied from -! transpose_chunk_to_block -! transpose buffer containing decomposed -! chunk data structures to buffer -! containing decomposed fields -! -! chunk_index identify whether index is for a latitude or -! a chunk -! -! FOLLOWING ARE NO LONGER USED, AND ARE CURRENTLY COMMENTED OUT -! get_gcol_owner_p get owner of column -! for given global physics column index + +!------------------------------------------------------------------------------ ! -! buff_to_chunk Copy from local buffer to local chunk data -! structure. (Needed for cpl6.) +! The phys_grid module represents the CAM physics decomposition. ! -! chunk_to_buff Copy from local chunk data structure to -! local buffer. (Needed for cpl6.) +! phys_grid_init receives the physics column info (area, weight, centers) +! from the dycore. +! The routine then creates the physics decomposition which +! is the arrangement of columns across the atmosphere model's +! MPI tasks as well as the arrangement into groups to +! facilitate efficient threading. +! The routine then creates a grid object to allow for data +! to be read into and written from this decomposition. +! The phys_grid module also provides interfaces for retrieving information +! about the decomposition ! -! Author: Patrick Worley and John Drake +! Note: This current implementation does not perform load balancing, +! physics columns ae always on the same task as the corresponding +! column received from the dycore. ! -!----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 - use physconst, only: pi - use ppgrid, only: pcols, pver, begchunk, endchunk -#if ( defined SPMD ) - use spmd_dyn, only: block_buf_nrecs, chunk_buf_nrecs, & - local_dp_map - use mpishorthand -#endif - use spmd_utils, only: iam, masterproc, npes, proc_smp_map, nsmps - use m_MergeSorts, only: IndexSet, IndexSort - use cam_abortutils, only: endrun - use perf_mod - use cam_logfile, only: iulog +!------------------------------------------------------------------------------ + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: begchunk, endchunk + use physics_column_type, only: physics_column_t + use perf_mod, only: t_adj_detailf, t_startf, t_stopf implicit none + private save -#if ( ! defined SPMD ) - integer, private :: block_buf_nrecs - integer, private :: chunk_buf_nrecs - logical, private :: local_dp_map=.true. -#endif - -! The identifier for the physics grid - integer, parameter, public :: phys_decomp = 100 - -! dynamics field grid information - integer, private :: hdim1_d, hdim2_d - ! dimensions of rectangular horizontal grid - ! data structure, If 1D data structure, then - ! hdim2_d == 1. - -! physics field data structures - integer, private :: ngcols ! global column count in physics grid (all) - integer, public :: num_global_phys_cols ! global column count in phys grid - ! (without holes) - - integer, dimension(:), allocatable, private :: dyn_to_latlon_gcol_map - ! map from unsorted (dynamics) to lat/lon sorted grid indices - integer, dimension(:), allocatable, private :: latlon_to_dyn_gcol_map - ! map from lat/lon sorted grid to unsorted (dynamics) indices - integer, dimension(:), allocatable, private :: lonlat_to_dyn_gcol_map - ! map from lon/lat sorted grid to unsorted (dynamics) indices - - integer, private :: clat_p_tot ! number of unique latitudes - integer, private :: clon_p_tot ! number of unique longitudes - - integer, dimension(:), allocatable, private :: clat_p_cnt ! number of repeats for each latitude - integer, dimension(:), allocatable, private :: clat_p_idx ! index in latlon ordering for first occurence - ! of latitude corresponding to given - ! latitude index - real(r8), dimension(:), allocatable :: clat_p ! unique latitudes (radians, increasing) - - - integer, dimension(:), allocatable, private :: clon_p_cnt ! number of repeats for each longitude - real(r8), dimension(:), allocatable :: clon_p ! unique longitudes (radians, increasing) - - integer, dimension(:), allocatable, private :: lat_p ! index into list of unique column latitudes - integer, dimension(:), allocatable, private :: lon_p ! index into list of unique column longitudes - -! chunk data structures - type chunk - integer :: ncols ! number of vertical columns - integer :: gcol(pcols) ! global physics column indices - integer :: lon(pcols) ! global longitude indices - integer :: lat(pcols) ! global latitude indices - integer :: owner ! id of process where chunk assigned - integer :: lcid ! local chunk index +!!XXgoldyXX: v This needs to be removed to complete the weak scaling transition. + public :: SCATTER_FIELD_TO_CHUNK +!!XXgoldyXX: ^ This needs to be removed to complete the weak scaling transition. + + ! Physics grid management + public :: phys_grid_init ! initialize the physics grid + public :: phys_grid_readnl ! Read the phys_grid_nl namelist + public :: phys_grid_initialized + ! Local task interfaces + public :: get_nlcols_p ! Number of local columns + public :: get_area_p ! area of a physics column in radians squared + public :: get_wght_p ! weight of a physics column in radians squared + public :: get_rlat_p ! latitude of a physics column in radians + public :: get_rlon_p ! longitude of a physics column in radians + public :: get_rlat_all_p ! latitudes of physics cols in chunk (radians) + public :: get_rlon_all_p ! longitudes of physics cols in chunk (radians) + public :: get_lat_p ! latitude of a physics column in degrees + public :: get_lon_p ! longitude of a physics column in degrees + public :: get_lat_all_p ! latitudes of physics cols in chunk (degrees) + public :: get_lon_all_p ! longitudes of physics cols in chunk (degrees) + public :: get_area_all_p ! areas of physics cols in chunk + public :: get_wght_all_p ! weights of physics cols in chunk + public :: get_ncols_p ! number of columns in a chunk + public :: get_gcol_p ! global column index of a physics column + public :: get_gcol_all_p ! global col index of all phys cols in a chunk + public :: get_dyn_col_p ! dynamics local blk number and blk offset(s) + public :: get_chunk_info_p ! chunk index and col # of a physics column + public :: get_grid_dims ! return grid dimensions + ! Physics-dynamics coupling + public :: phys_decomp_to_dyn ! Transfer physics data to dynamics decomp + public :: dyn_decomp_to_phys ! Transfer dynamics data to physics decomp + + ! The identifier for the physics grid + integer, parameter, public :: phys_decomp = 100 + + !! PUBLIC TYPES + + ! Physics chunking (thread blocking) data + ! Note that chunks cover local data + type, public :: chunk + integer, private :: ncols = 1 ! # of grid columns in this chunk + integer, private :: chunk_index = -1 ! Local index of this chunk + integer, private, allocatable :: phys_cols(:) ! phys column indices end type chunk - integer :: nchunks ! global chunk count - type (chunk), dimension(:), allocatable, public :: chunks - ! global computational grid - - integer, dimension(:), allocatable, private :: npchunks - ! number of chunks assigned to each process - - type lchunk - integer :: ncols ! number of vertical columns - integer :: cid ! global chunk index - integer :: gcol(pcols) ! global physics column indices - real(r8) :: area(pcols) ! column surface area (from dynamics) - real(r8) :: wght(pcols) ! column integration weight (from dynamics) - end type lchunk - - integer, private :: nlchunks ! local chunk count - type (lchunk), dimension(:), allocatable, private :: lchunks - ! local chunks - - type knuhc - integer :: chunkid ! chunk id - integer :: col ! column index in chunk - end type knuhc - - type (knuhc), dimension(:), allocatable, private :: knuhcs - ! map from global column indices - ! to chunk'ed grid - -! column mapping data structures - type column_map - integer :: chunk ! global chunk index - integer :: ccol ! column ordering in chunk - end type column_map - - integer, private :: nlcols ! local column count - type (column_map), dimension(:), allocatable, private :: pgcols - ! ordered list of columns (for use in gather/scatter) - ! NOTE: consistent with local ordering - -! column remap data structures - integer, dimension(:), allocatable, private :: gs_col_num - ! number of columns scattered to each process in - ! field_to_chunk scatter - integer, dimension(:), allocatable, private :: gs_col_offset - ! offset of columns (-1) in pgcols scattered to - ! each process in field_to_chunk scatter - - integer, dimension(:), allocatable, private :: btofc_blk_num - ! number of grid points scattered to each process in - ! block_to_chunk alltoallv, and gathered from each - ! process in chunk_to_block alltoallv - - integer, dimension(:), allocatable, private :: btofc_chk_num - ! number of grid points gathered from each process in - ! block_to_chunk alltoallv, and scattered to each - ! process in chunk_to_block alltoallv - - type btofc_pters - integer :: ncols ! number of columns in block - integer :: nlvls ! number of levels in columns - integer, dimension(:,:), pointer :: pter - end type btofc_pters - type (btofc_pters), dimension(:), allocatable, private :: btofc_blk_offset - ! offset in btoc send array (-1) where - ! (blockid, bcid, k) column should be packed in - ! block_to_chunk alltoallv, AND - ! offset in ctob receive array (-1) from which - ! (blockid, bcid, k) column should be unpacked in - ! chunk_to_block alltoallv - - type (btofc_pters), dimension(:), allocatable, private :: btofc_chk_offset - ! offset in btoc receive array (-1) from which - ! (lcid, i, k) data should be unpacked in - ! block_to_chunk alltoallv, AND - ! offset in ctob send array (-1) where - ! (lcid, i, k) data should be packed in - ! chunk_to_block alltoallv - -! miscellaneous phys_grid data - integer, private :: dp_coup_steps ! number of swaps in transpose algorithm - integer, dimension(:), private, allocatable :: dp_coup_proc - ! swap partner in each step of - ! transpose algorithm - logical :: physgrid_set = .false. ! flag indicates physics grid has been set - integer, private :: max_nproc_smpx ! maximum number of processes assigned to a - ! single virtual SMP used to define physics - ! load balancing - integer, private :: nproc_busy_d ! number of processes active during the dynamics - ! (assigned a dynamics block) - -! Physics grid decomposition options: -! -1: each chunk is a dynamics block -! 0: chunk definitions and assignments do not require interprocess comm. -! 1: chunk definitions and assignments do not require internode comm. -! 2: chunk definitions and assignments may require communication between all processes -! 3: chunk definitions and assignments only require communication with one other process -! 4: concatenated blocks, no load balancing, no interprocess communication - integer, private, parameter :: min_lbal_opt = -1 - integer, private, parameter :: max_lbal_opt = 5 - integer, private, parameter :: def_lbal_opt = 2 ! default - integer, private :: lbal_opt = def_lbal_opt - -! Physics grid load balancing options: -! 0: assign columns to chunks as single columns, wrap mapped across chunks -! 1: use (day/night; north/south) twin algorithm to determine load-balanced pairs of -! columns and assign columns to chunks in pairs, wrap mapped - integer, private, parameter :: min_twin_alg = 0 - integer, private, parameter :: max_twin_alg = 1 - integer, private, parameter :: def_twin_alg_lonlat = 1 ! default - integer, private, parameter :: def_twin_alg_unstructured = 0 - integer, private :: twin_alg = def_twin_alg_lonlat - -! target number of chunks per thread - integer, private, parameter :: min_chunks_per_thread = 1 - integer, private, parameter :: def_chunks_per_thread = & - min_chunks_per_thread ! default - integer, private :: chunks_per_thread = def_chunks_per_thread - -! Dynamics/physics transpose method for nonlocal load-balance: -! -1: use "0" if max_nproc_smpx and nproc_busy_d are both > npes/2; otherwise use "1" -! 0: use mpi_alltoallv -! 1: use point-to-point MPI-1 two-sided implementation -! 2: use point-to-point MPI-2 one-sided implementation if supported, -! otherwise use MPI-1 implementation -! 3: use Co-Array Fortran implementation if supported, -! otherwise use MPI-1 implementation -! 11-13: use mod_comm, choosing any of several methods internal to mod_comm. -! The method within mod_comm (denoted mod_method) has possible values 0,1,2 and -! is set according to mod_method = phys_alltoall - modmin_alltoall, where -! modmin_alltoall is 11. - integer, private, parameter :: min_alltoall = -1 - integer, private, parameter :: max_alltoall = 3 -# if defined(MODCM_DP_TRANSPOSE) - integer, private, parameter :: modmin_alltoall = 11 - integer, private, parameter :: modmax_alltoall = 13 -# endif - integer, private, parameter :: def_alltoall = -1 ! default - integer, private :: phys_alltoall = def_alltoall - - logical :: calc_memory_increase = .false. - -!======================================================================== -contains -!======================================================================== - -subroutine phys_grid_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, & - phys_mirror_decomp_req -#if defined(MODCM_DP_TRANSPOSE) - use mod_comm, only: phys_transpose_mod -#endif - use dycore, only: dycore_is - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'phys_grid_readnl' - - integer :: phys_loadbalance - integer :: phys_twin_algorithm - integer :: phys_chnk_per_thd - - namelist /phys_grid_nl/ phys_alltoall, phys_loadbalance, phys_twin_algorithm, & - phys_chnk_per_thd - !----------------------------------------------------------------------------- - - ! Initialize namelist vars - phys_loadbalance = def_lbal_opt - - if (dycore_is('UNSTRUCTURED')) then - phys_twin_algorithm = def_twin_alg_unstructured - else - phys_twin_algorithm = def_twin_alg_lonlat - endif - - phys_chnk_per_thd = def_chunks_per_thread - - ! Read namelist - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'phys_grid_nl', status=ierr) - if (ierr == 0) then - read(unitn, phys_grid_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub//': FATAL: reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - call mpi_bcast(phys_alltoall, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_alltoall") - call mpi_bcast(phys_loadbalance, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_loadbalance") - call mpi_bcast(phys_twin_algorithm, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_twin_algorithm") - call mpi_bcast(phys_chnk_per_thd, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_chnk_per_thd") - - ! set module variables from namelist vars - - lbal_opt = phys_loadbalance - - if (lbal_opt == 3) then - phys_mirror_decomp_req = .true. - else - phys_mirror_decomp_req = .false. - endif - - twin_alg = phys_twin_algorithm - - chunks_per_thread = phys_chnk_per_thd - - ! Some consistency checks - - if (((phys_alltoall < min_alltoall) .or. & - (phys_alltoall > max_alltoall)) & -# if defined(MODCM_DP_TRANSPOSE) - .and. & - ((phys_alltoall < modmin_alltoall) .or. & - (phys_alltoall > modmax_alltoall)) & -# endif - ) then - if (masterproc) then - write(iulog,*) sub//': ERROR: phys_alltoall=', phys_alltoall, & - ' is out of range. It must be between ', min_alltoall, ' and ', max_alltoall - endif - call endrun(sub//': ERROR setting phys_alltoall') - endif -#if defined(SPMD) -#if defined(MODCM_DP_TRANSPOSE) - phys_transpose_mod = phys_alltoall -#endif -#endif - - if ((lbal_opt < min_lbal_opt).or.(lbal_opt > max_lbal_opt)) then - if (masterproc) then - write(iulog,*) sub//': ERROR: phys_loadbalance=', phys_loadbalance, & - ' is out of range. It must be between ', min_lbal_opt, ' and ', max_lbal_opt - endif - call endrun(sub//': ERROR setting phys_loadbalance') - endif + !! PRIVATE DATA - if ((twin_alg < min_twin_alg).or.(twin_alg > max_twin_alg)) then - if (masterproc) then - write(iulog,*) sub//': ERROR: phys_twin_algorithm=', phys_twin_algorithm, & - ' is out of range. It must be between ', min_twin_alg, ' and ', max_twin_alg - endif - call endrun(sub//': ERROR setting phys_twin_algorithm') - endif + ! dynamics field grid information + ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then hdim2_d == 1. + integer :: hdim1_d, hdim2_d - if (chunks_per_thread < min_chunks_per_thread) then - if (masterproc) then - write(iulog,*) sub//': ERROR: phys_chnk_per_thd=', phys_chnk_per_thd, & - ' is too small. It must not be smaller than ', min_chunks_per_thread - endif - call endrun(sub//': ERROR setting phys_chnk_per_thd') - endif - - - if (masterproc) then - write(iulog,*) 'PHYS_GRID options:' - write(iulog,*) ' Using PCOLS =', pcols - write(iulog,*) ' phys_loadbalance =', lbal_opt - write(iulog,*) ' phys_twin_algorithm =', twin_alg - write(iulog,*) ' phys_alltoall =', phys_alltoall - write(iulog,*) ' chunks_per_thread =', chunks_per_thread - end if - -end subroutine phys_grid_readnl - -!=============================================================================== - - integer function get_nlcols_p() - get_nlcols_p = nlcols - end function get_nlcols_p - - subroutine phys_grid_init( ) - !----------------------------------------------------------------------- - ! - ! Purpose: Physics mapping initialization routine: - ! - ! Method: - ! - ! Author: John Drake and Patrick Worley - ! - !----------------------------------------------------------------------- - use mpi, only: MPI_REAL8, MPI_MAX - use shr_mem_mod, only: shr_mem_getusage - use pmgrid, only: plev - use dycore, only: dycore_is - use dyn_grid, only: get_block_bounds_d, & - get_block_gcol_d, get_block_gcol_cnt_d, & - get_block_levels_d, get_block_lvl_cnt_d, & - get_block_owner_d, & - get_gcol_block_d, get_gcol_block_cnt_d, & - get_horiz_grid_dim_d, get_horiz_grid_d, physgrid_copy_attributes_d - use spmd_utils, only: pair, ceil2, masterprocid, mpicom - use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register - use cam_grid_support, only: iMap, max_hcoordname_len - use cam_grid_support, only: horiz_coord_t, horiz_coord_create - use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists - - ! - !------------------------------Arguments-------------------------------- - ! - ! - !---------------------------Local workspace----------------------------- - ! - integer :: i, j, jb, k, p ! loop indices - integer :: pre_i ! earlier index in loop iteration - integer :: clat_p_dex, clon_p_dex ! indices into unique lat. and lon. arrays - integer :: maxblksiz ! maximum number of columns in a dynamics block - integer :: beg_dex, end_dex ! index range - integer :: cid, lcid ! global and local chunk ids - integer :: max_ncols ! upper bound on number of columns in a block - integer :: ncols ! number of columns in current chunk - integer :: curgcol, curgcol_d ! current global column index - integer :: firstblock, lastblock ! global block indices - integer :: blksiz ! current block size - integer :: glbcnt, curcnt ! running grid point counts - integer :: curp ! current process id - integer :: block_cnt ! number of blocks containing data - ! for a given vertical column - integer :: numlvl ! number of vertical levels in block - ! column - integer :: levels(plev+1) ! vertical level indices - integer :: owner_d ! process owning given block column - integer :: owner_p ! process owning given chunk column - integer :: blockids(plev+1) ! block indices - integer :: bcids(plev+1) ! block column indices - - - ! column surface area (from dynamics) - real(r8), dimension(:), pointer :: area_d - - ! column surface areawt (from dynamics) - real(r8), dimension(:), pointer :: areawt_d - - ! column integration weight (from dynamics) - real(r8), dimension(:), allocatable :: wght_d - - ! chunk global ordering - integer, dimension(:), allocatable :: pchunkid - - ! permutation array used in physics column sorting; - ! reused later as work space in (lbal_opt == -1) logic - integer, dimension(:), allocatable :: cdex - - ! latitudes and longitudes and column area for dynamics columns - real(r8), dimension(:), allocatable :: clat_d - real(r8), dimension(:), allocatable :: clon_d - real(r8), dimension(:), allocatable :: lat_d - real(r8), dimension(:), allocatable :: lon_d - real(r8) :: clat_p_tmp - real(r8) :: clon_p_tmp - - ! Maps and values for physics grid - real(r8), pointer :: lonvals(:) - real(r8), pointer :: latvals(:) - real(r8), allocatable :: latdeg_p(:) - real(r8), allocatable :: londeg_p(:) - integer(iMap), pointer :: grid_map(:,:) - integer(iMap), allocatable :: coord_map(:) - type(horiz_coord_t), pointer :: lat_coord - type(horiz_coord_t), pointer :: lon_coord - integer :: gcols(pcols) - character(len=max_hcoordname_len), pointer :: copy_attributes(:) - character(len=max_hcoordname_len) :: copy_gridname - logical :: unstructured - real(r8) :: lonmin, latmin - real(r8) :: mem_hw_beg, mem_hw_end - real(r8) :: mem_beg, mem_end - - nullify(area_d) - nullify(lonvals) - nullify(latvals) - nullify(grid_map) - nullify(lat_coord) - nullify(lon_coord) - - if (calc_memory_increase) then - call shr_mem_getusage(mem_hw_beg, mem_beg) - end if - - call t_startf("phys_grid_init") - - !----------------------------------------------------------------------- - ! - ! Initialize physics grid, using dynamics grid - ! a) column coordinates - - call get_horiz_grid_dim_d(hdim1_d,hdim2_d) - ngcols = hdim1_d*hdim2_d - allocate( clat_d(1:ngcols) ) - allocate( clon_d(1:ngcols) ) - allocate( lat_d(1:ngcols) ) - allocate( lon_d(1:ngcols) ) - allocate( cdex(1:ngcols) ) - clat_d = 100000.0_r8 - clon_d = 100000.0_r8 - call get_horiz_grid_d(ngcols, clat_d_out=clat_d, clon_d_out=clon_d, lat_d_out=lat_d, lon_d_out=lon_d) - latmin = minval(lat_d) - lonmin = minval(lon_d) - - ! count number of "real" column indices - num_global_phys_cols = 0 - do i=1,ngcols - if (clon_d(i) < 100000.0_r8) then - num_global_phys_cols = num_global_phys_cols + 1 - endif - enddo - - ! sort over longitude and identify unique longitude coordinates - call IndexSet(ngcols,cdex) - call IndexSort(ngcols,cdex,clon_d,descend=.false.) - clon_p_tmp = clon_d(cdex(1)) - clon_p_tot = 1 - - do i=2,num_global_phys_cols - if (clon_d(cdex(i)) > clon_p_tmp) then - clon_p_tot = clon_p_tot + 1 - clon_p_tmp = clon_d(cdex(i)) - endif - enddo - - allocate( clon_p(1:clon_p_tot) ) - allocate( clon_p_cnt(1:clon_p_tot) ) - allocate( londeg_p(1:clon_p_tot) ) - - pre_i = 1 - clon_p_tot = 1 - clon_p(1) = clon_d(cdex(1)) - londeg_p(1) = lon_d(cdex(1)) - do i=2,num_global_phys_cols - if (clon_d(cdex(i)) > clon_p(clon_p_tot)) then - clon_p_cnt(clon_p_tot) = i-pre_i - pre_i = i - clon_p_tot = clon_p_tot + 1 - clon_p(clon_p_tot) = clon_d(cdex(i)) - londeg_p(clon_p_tot) = lon_d(cdex(i)) - endif - enddo - clon_p_cnt(clon_p_tot) = (num_global_phys_cols+1)-pre_i - - ! sort over latitude and identify unique latitude coordinates - call IndexSet(ngcols,cdex) - call IndexSort(ngcols,cdex,clat_d,descend=.false.) - clat_p_tmp = clat_d(cdex(1)) - clat_p_tot = 1 - do i=2,num_global_phys_cols - if (clat_d(cdex(i)) > clat_p_tmp) then - clat_p_tot = clat_p_tot + 1 - clat_p_tmp = clat_d(cdex(i)) - endif - enddo - - allocate( clat_p(1:clat_p_tot) ) - allocate( clat_p_cnt(1:clat_p_tot) ) - allocate( clat_p_idx(1:clat_p_tot) ) - allocate( latdeg_p(1:clat_p_tot) ) - - pre_i = 1 - clat_p_tot = 1 - clat_p(1) = clat_d(cdex(1)) - latdeg_p(1) = lat_d(cdex(1)) - do i=2,num_global_phys_cols - if (clat_d(cdex(i)) > clat_p(clat_p_tot)) then - clat_p_cnt(clat_p_tot) = i-pre_i - pre_i = i - clat_p_tot = clat_p_tot + 1 - clat_p(clat_p_tot) = clat_d(cdex(i)) - latdeg_p(clat_p_tot) = lat_d(cdex(i)) - endif - enddo - clat_p_cnt(clat_p_tot) = (num_global_phys_cols+1)-pre_i - - clat_p_idx(1) = 1 - do j=2,clat_p_tot - clat_p_idx(j) = clat_p_idx(j-1) + clat_p_cnt(j-1) - enddo - - deallocate(lat_d) - deallocate(lon_d) - - ! sort by longitude within latitudes - end_dex = 0 - do j=1,clat_p_tot - beg_dex = end_dex + 1 - end_dex = end_dex + clat_p_cnt(j) - call IndexSort(cdex(beg_dex:end_dex),clon_d,descend=.false.) - enddo - - ! Early clean-up, to minimize memory high water mark - ! (not executing find_partner or find_twin) - if (((twin_alg /= 1) .and. (lbal_opt /= 3)) .or. (lbal_opt == -1)) then - deallocate( clat_p_cnt) - end if - - ! save "longitude within latitude" column ordering - ! and determine mapping from unsorted global column index to - ! unique latitude/longitude indices - allocate( lat_p(1:ngcols) ) - allocate( lon_p(1:ngcols) ) - allocate( dyn_to_latlon_gcol_map(1:ngcols) ) - if (lbal_opt /= -1) then - allocate(latlon_to_dyn_gcol_map(1:num_global_phys_cols)) - end if - - clat_p_dex = 1 - lat_p = -1 - dyn_to_latlon_gcol_map = -1 - do i = 1, num_global_phys_cols - if (lbal_opt /= -1) latlon_to_dyn_gcol_map(i) = cdex(i) - dyn_to_latlon_gcol_map(cdex(i)) = i - - do while ((clat_p(clat_p_dex) < clat_d(cdex(i))) .and. & - (clat_p_dex < clat_p_tot)) - clat_p_dex = clat_p_dex + 1 - enddo - lat_p(cdex(i)) = clat_p_dex - enddo - - ! sort by latitude within longitudes - call IndexSet(ngcols,cdex) - call IndexSort(ngcols,cdex,clon_d,descend=.false.) - end_dex = 0 - do i=1,clon_p_tot - beg_dex = end_dex + 1 - end_dex = end_dex + clon_p_cnt(i) - call IndexSort(cdex(beg_dex:end_dex),clat_d,descend=.false.) - enddo - - ! Early clean-up, to minimize memory high water mark - ! (not executing find_twin) - if ((twin_alg /= 1) .or. (lbal_opt == -1)) deallocate( clon_p_cnt ) - - ! save "latitude within longitude" column ordering - ! (only need in find_twin) - if ((twin_alg == 1) .and. (lbal_opt /= -1)) & - allocate( lonlat_to_dyn_gcol_map(1:num_global_phys_cols) ) - - clon_p_dex = 1 - lon_p = -1 - do i=1,num_global_phys_cols - if ((twin_alg == 1) .and. (lbal_opt /= -1)) & - lonlat_to_dyn_gcol_map(i) = cdex(i) - do while ((clon_p(clon_p_dex) < clon_d(cdex(i))) .and. & - (clon_p_dex < clon_p_tot)) - clon_p_dex = clon_p_dex + 1 - enddo - lon_p(cdex(i)) = clon_p_dex - enddo - - ! Clean-up - deallocate( clat_d ) - deallocate( clon_d ) - deallocate( cdex ) - - ! - ! Determine block index bounds - ! - call get_block_bounds_d(firstblock,lastblock) - - ! Allocate storage to save number of chunks and columns assigned to each - ! process during chunk creation and assignment - ! - allocate( npchunks(0:npes-1) ) - allocate( gs_col_num(0:npes-1) ) - npchunks(:) = 0 - gs_col_num(:) = 0 - - ! - ! Option -1: each dynamics block is a single chunk - ! - if (lbal_opt == -1) then - ! - ! Check that pcols >= maxblksiz - ! - maxblksiz = 0 - do jb=firstblock,lastblock - maxblksiz = max(maxblksiz,get_block_gcol_cnt_d(jb)) - enddo - if (pcols < maxblksiz) then - write(iulog,*) 'pcols = ',pcols, ' maxblksiz=',maxblksiz - call endrun ('PHYS_GRID_INIT error: phys_loadbalance -1 specified but PCOLS < MAXBLKSIZ') - endif - - ! - ! Determine total number of chunks - ! - nchunks = (lastblock-firstblock+1) - - ! - ! Set max virtual SMP node size - ! - max_nproc_smpx = 1 - - ! - ! Allocate and initialize chunks data structure - ! - allocate( cdex(1:maxblksiz) ) - allocate( chunks(1:nchunks) ) - - do cid=1,nchunks - ! get number of global column indices in block - max_ncols = get_block_gcol_cnt_d(cid+firstblock-1) - ! fill cdex array with global indices from current block - call get_block_gcol_d(cid+firstblock-1,max_ncols,cdex) - - ncols = 0 - do i=1,max_ncols - ! check whether global index is for a column that dynamics - ! intends to pass to the physics - curgcol_d = cdex(i) - if (dyn_to_latlon_gcol_map(curgcol_d) /= -1) then - ! yes - then save the information - ncols = ncols + 1 - chunks(cid)%gcol(ncols) = curgcol_d - chunks(cid)%lat(ncols) = lat_p(curgcol_d) - chunks(cid)%lon(ncols) = lon_p(curgcol_d) - endif - enddo - chunks(cid)%ncols = ncols - enddo - - ! Clean-up - deallocate( cdex ) - deallocate( lat_p ) - deallocate( lon_p ) - - ! - ! Specify parallel decomposition - ! - do cid=1,nchunks -#if (defined SPMD) - p = get_block_owner_d(cid+firstblock-1) -#else - p = 0 -#endif - chunks(cid)%owner = p - npchunks(p) = npchunks(p) + 1 - gs_col_num(p) = gs_col_num(p) + chunks(cid)%ncols - enddo - ! - ! Set flag indicating columns in physics and dynamics - ! decompositions reside on the same processes - ! - local_dp_map = .true. - ! - else - ! - ! Option == 0: split local blocks into chunks, - ! while attempting to create load-balanced chunks. - ! Does not work with vertically decomposed blocks. - ! (default) - ! Option == 1: split SMP-local blocks into chunks, - ! while attempting to create load-balanced chunks. - ! Does not work with vertically decomposed blocks. - ! Option == 2: load balance chunks with respect to diurnal and - ! seaonsal cycles and wth respect to latitude, - ! and assign chunks to processes - ! in a way that attempts to minimize communication costs - ! Option == 3: divide processes into pairs and split - ! blocks assigned to these pairs into - ! chunks, attempting to create load-balanced chunks. - ! The process pairs are chosen to maximize load balancing - ! opportunities. - ! Does not work with vertically decomposed blocks. - ! Option == 4: concatenate local blocks, then - ! divide into chunks. - ! Does not work with vertically decomposed blocks. - ! Option == 5: split indiviudal blocks into chunks, - ! assigning columns using block ordering - ! - ! - ! Allocate and initialize chunks data structure, then - ! assign chunks to processes. - ! - call create_chunks(lbal_opt, chunks_per_thread) - - ! Early clean-up, to minimize memory high water mark - deallocate( lat_p ) - deallocate( lon_p ) - deallocate( latlon_to_dyn_gcol_map ) - if (twin_alg == 1) deallocate( lonlat_to_dyn_gcol_map ) - if (twin_alg == 1) deallocate( clon_p_cnt ) - if ((twin_alg == 1) .or. (lbal_opt == 3)) deallocate( clat_p_cnt ) - - ! - ! Determine whether dynamics and physics decompositions - ! are colocated, not requiring any interprocess communication - ! in the coupling. - local_dp_map = .true. - do cid=1,nchunks - do i=1,chunks(cid)%ncols - curgcol_d = chunks(cid)%gcol(i) - block_cnt = get_gcol_block_cnt_d(curgcol_d) - call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) - do jb=1,block_cnt - owner_d = get_block_owner_d(blockids(jb)) - if (owner_d /= chunks(cid)%owner) then - local_dp_map = .false. - endif - enddo - enddo - enddo - endif - ! - ! Allocate and initialize data structures for gather/scatter - ! - allocate( pgcols(1:num_global_phys_cols) ) - allocate( gs_col_offset(0:npes) ) - allocate( pchunkid(0:npes) ) - - ! Initialize pchunkid and gs_col_offset by summing - ! number of chunks and columns per process, respectively - pchunkid(0) = 0 - gs_col_offset(0) = 0 - do p=1,npes-1 - pchunkid(p) = pchunkid(p-1) + npchunks(p-1) - gs_col_offset(p) = gs_col_offset(p-1) + gs_col_num(p-1) - enddo - - ! Determine local ordering via "process id" bin sort - do cid=1,nchunks - p = chunks(cid)%owner - pchunkid(p) = pchunkid(p) + 1 - - chunks(cid)%lcid = pchunkid(p) + lastblock - - curgcol = gs_col_offset(p) - do i=1,chunks(cid)%ncols - curgcol = curgcol + 1 - pgcols(curgcol)%chunk = cid - pgcols(curgcol)%ccol = i - enddo - gs_col_offset(p) = curgcol - enddo - - ! Reinitialize pchunkid and gs_col_offset (for real) - pchunkid(0) = 1 - gs_col_offset(0) = 1 - do p=1,npes-1 - pchunkid(p) = pchunkid(p-1) + npchunks(p-1) - gs_col_offset(p) = gs_col_offset(p-1) + gs_col_num(p-1) - enddo - pchunkid(npes) = pchunkid(npes-1) + npchunks(npes-1) - gs_col_offset(npes) = gs_col_offset(npes-1) + gs_col_num(npes-1) - - ! Save local information - ! (Local chunk index range chosen so that it does not overlap - ! {begblock,...,endblock}) - ! - nlcols = gs_col_num(iam) - nlchunks = npchunks(iam) - begchunk = pchunkid(iam) + lastblock - endchunk = pchunkid(iam+1) + lastblock - 1 - ! - allocate( lchunks(begchunk:endchunk) ) - do cid=1,nchunks - if (chunks(cid)%owner == iam) then - lcid = chunks(cid)%lcid - lchunks(lcid)%ncols = chunks(cid)%ncols - lchunks(lcid)%cid = cid - do i=1,chunks(cid)%ncols - lchunks(lcid)%gcol(i) = chunks(cid)%gcol(i) - enddo - endif - enddo - - deallocate( pchunkid ) - deallocate( npchunks ) - ! - !----------------------------------------------------------------------- - ! - ! Initialize physics grid, using dynamics grid - ! b) column area and integration weight - - allocate( area_d(1:ngcols) ) - allocate( wght_d(1:ngcols) ) - area_d = 0.0_r8 - wght_d = 0.0_r8 - - call get_horiz_grid_d(ngcols, area_d_out=area_d, wght_d_out=wght_d) - - - if ( abs(sum(area_d) - 4.0_r8*pi) > 1.e-10_r8 ) then - write(iulog,*) ' ERROR: sum of areas on globe does not equal 4*pi' - write(iulog,*) ' sum of areas = ', sum(area_d), sum(area_d)-4.0_r8*pi - call endrun('phys_grid') - end if - - if ( abs(sum(wght_d) - 4.0_r8*pi) > 1.e-10_r8 ) then - write(iulog,*) ' ERROR: sum of integration weights on globe does not equal 4*pi' - write(iulog,*) ' sum of weights = ', sum(wght_d), sum(wght_d)-4.0_r8*pi - call endrun('phys_grid') - end if - - do lcid=begchunk,endchunk - do i=1,lchunks(lcid)%ncols - lchunks(lcid)%area(i) = area_d(lchunks(lcid)%gcol(i)) - lchunks(lcid)%wght(i) = wght_d(lchunks(lcid)%gcol(i)) - enddo - enddo - - deallocate( area_d ) - nullify(area_d) - deallocate( wght_d ) - - if (.not. local_dp_map) then - ! - ! allocate and initialize data structures for transposes - ! - allocate( btofc_blk_num(0:npes-1) ) - btofc_blk_num = 0 - allocate( btofc_blk_offset(firstblock:lastblock) ) - do jb = firstblock,lastblock - nullify( btofc_blk_offset(jb)%pter ) - enddo - ! - glbcnt = 0 - curcnt = 0 - curp = 0 - do curgcol=1,num_global_phys_cols - cid = pgcols(curgcol)%chunk - i = pgcols(curgcol)%ccol - owner_p = chunks(cid)%owner - do while (curp < owner_p) - btofc_blk_num(curp) = curcnt - curcnt = 0 - curp = curp + 1 - enddo - curgcol_d = chunks(cid)%gcol(i) - block_cnt = get_gcol_block_cnt_d(curgcol_d) - call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) - do jb = 1,block_cnt - owner_d = get_block_owner_d(blockids(jb)) - if (iam == owner_d) then - if (.not. associated(btofc_blk_offset(blockids(jb))%pter)) then - blksiz = get_block_gcol_cnt_d(blockids(jb)) - numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb)) - btofc_blk_offset(blockids(jb))%ncols = blksiz - btofc_blk_offset(blockids(jb))%nlvls = numlvl - allocate( btofc_blk_offset(blockids(jb))%pter(blksiz,numlvl) ) - endif - do k=1,btofc_blk_offset(blockids(jb))%nlvls - btofc_blk_offset(blockids(jb))%pter(bcids(jb),k) = glbcnt - curcnt = curcnt + 1 - glbcnt = glbcnt + 1 - enddo - endif - enddo - enddo - btofc_blk_num(curp) = curcnt - block_buf_nrecs = glbcnt - ! - allocate( btofc_chk_num(0:npes-1) ) - btofc_chk_num = 0 - allocate( btofc_chk_offset(begchunk:endchunk) ) - do lcid=begchunk,endchunk - ncols = lchunks(lcid)%ncols - btofc_chk_offset(lcid)%ncols = ncols - btofc_chk_offset(lcid)%nlvls = pver+1 - allocate( btofc_chk_offset(lcid)%pter(ncols,pver+1) ) - enddo - ! - curcnt = 0 - glbcnt = 0 - do p=0,npes-1 - do curgcol=gs_col_offset(iam),gs_col_offset(iam+1)-1 - cid = pgcols(curgcol)%chunk - owner_p = chunks(cid)%owner - if (iam == owner_p) then - i = pgcols(curgcol)%ccol - lcid = chunks(cid)%lcid - curgcol_d = chunks(cid)%gcol(i) - block_cnt = get_gcol_block_cnt_d(curgcol_d) - call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) - do jb = 1,block_cnt - owner_d = get_block_owner_d(blockids(jb)) - if (p == owner_d) then - numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb)) - call get_block_levels_d(blockids(jb),bcids(jb),numlvl,levels) - do k=1,numlvl - btofc_chk_offset(lcid)%pter(i,levels(k)+1) = glbcnt - curcnt = curcnt + 1 - glbcnt = glbcnt + 1 - enddo - endif - enddo - endif - enddo - btofc_chk_num(p) = curcnt - curcnt = 0 - enddo - chunk_buf_nrecs = glbcnt - ! - ! Precompute swap partners and number of steps in point-to-point - ! implementations of alltoall algorithm. - ! First, determine number of swaps. - ! - dp_coup_steps = 0 - do i=1,ceil2(npes)-1 - p = pair(npes,i,iam) - if (p >= 0) then - if ((btofc_blk_num(p) > 0 .or. btofc_chk_num(p) > 0)) then - dp_coup_steps = dp_coup_steps + 1 - end if - end if - end do - ! - ! Second, determine swap partners. - ! - allocate( dp_coup_proc(dp_coup_steps) ) - dp_coup_steps = 0 - do i=1,ceil2(npes)-1 - p = pair(npes,i,iam) - if (p >= 0) then - if ((btofc_blk_num(p) > 0 .or. btofc_chk_num(p) > 0)) then - dp_coup_steps = dp_coup_steps + 1 - dp_coup_proc(dp_coup_steps) = p - end if - end if - end do - ! - endif - - ! Final clean-up - deallocate( gs_col_offset ) - ! (if eliminate get_lon_xxx, can also deallocate - ! clat_p_idx, and grid_latlon?)) - - ! Add physics-package grid to set of CAM grids - ! physgrid always uses 'lat' and 'lon' as coordinate names; If dynamics - ! grid is different, it will use different coordinate names - - ! First, create a map for the physics grid - ! It's structure will depend on whether or not the physics grid is - ! unstructured - unstructured = dycore_is('UNSTRUCTURED') - if (unstructured) then - allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) - else - allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) - end if - grid_map = 0 - allocate(latvals(size(grid_map, 2))) - allocate(lonvals(size(grid_map, 2))) - p = 0 - do lcid = begchunk, endchunk - ncols = lchunks(lcid)%ncols - call get_gcol_all_p(lcid, pcols, gcols) - ! collect latvals and lonvals - cid = lchunks(lcid)%cid - do i = 1, chunks(cid)%ncols - latvals(p + i) = latdeg_p(chunks(cid)%lat(i)) - lonvals(p + i) = londeg_p(chunks(cid)%lon(i)) - end do - if (pcols > ncols) then - ! Need to set these to detect unused columns - latvals(p+ncols+1:p+pcols) = 1000.0_r8 - lonvals(p+ncols+1:p+pcols) = 1000.0_r8 - end if + ! Physics decomposition information + type(physics_column_t), allocatable :: phys_columns(:) - ! Set grid values for this chunk - do i = 1, pcols - p = p + 1 - grid_map(1, p) = i - grid_map(2, p) = lcid - if ((i <= ncols) .and. (gcols(i) > 0)) then - if (unstructured) then - grid_map(3, p) = gcols(i) - else - grid_map(3, p) = get_lon_p(lcid, i) - grid_map(4, p) = get_lat_p(lcid, i) - end if - else - if (i <= ncols) then - call endrun("phys_grid_init: unmapped column") - end if - end if - end do - end do - - ! Note that if the dycore is using the same points as the physics grid, - ! it will have already set up 'lat' and 'lon' axes for the physics grid - ! However, these will be in the dynamics decomposition - if (unstructured) then - lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & - 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & - map=grid_map(3,:)) - lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & - 'latitude', 'degrees_north', 1, size(latvals), latvals, & - map=grid_map(3,:)) - else - - allocate(coord_map(size(grid_map, 2))) - - ! Create a lon coord map which only writes from one of each unique lon - where(latvals == latmin) - coord_map(:) = grid_map(3, :) - elsewhere - coord_map(:) = 0_iMap - end where - lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, 'longitude', & - 'degrees_east', 1, size(lonvals), lonvals, map=coord_map) - - ! Create a lat coord map which only writes from one of each unique lat - where(lonvals == lonmin) - coord_map(:) = grid_map(4, :) - elsewhere - coord_map(:) = 0_iMap - end where - lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, 'latitude', & - 'degrees_north', 1, size(latvals), latvals, map=coord_map) - - deallocate(coord_map) - - end if - call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & - grid_map, unstruct=unstructured, block_indexed=.true.) - ! Copy required attributes from the dynamics array - nullify(copy_attributes) - call physgrid_copy_attributes_d(copy_gridname, copy_attributes) - do i = 1, size(copy_attributes) - call cam_grid_attribute_copy(copy_gridname, 'physgrid', copy_attributes(i)) - end do - if ((.not. cam_grid_attr_exists('physgrid', 'area')) .and. unstructured) then - ! Physgrid always needs an area attribute. If we did not inherit one - ! from the dycore (i.e., physics and dynamics are on different grids), - ! create that attribute here (unstructured grids only, physgrid is - ! not supported for structured grids). - allocate(area_d(size(grid_map, 2))) - allocate(areawt_d(size(grid_map, 2))) - p = 0 - do lcid = begchunk, endchunk - ncols = lchunks(lcid)%ncols - call get_gcol_all_p(lcid, pcols, gcols) - ! collect latvals and lonvals - cid = lchunks(lcid)%cid - do i = 1, chunks(cid)%ncols - area_d(p + i) = lchunks(lcid)%area(i) - areawt_d(p + i) = lchunks(lcid)%wght(i) - end do - if (pcols > ncols) then - ! Need to set these to detect unused columns - area_d(p+ncols+1:p+pcols) = 0.0_r8 - areawt_d(p+ncols+1:p+pcols) = 0.0_r8 - end if - p = p + pcols - end do - call cam_grid_attribute_register('physgrid', 'area', & - 'physics column areas', 'ncol', area_d, map=grid_map(3,:)) - call cam_grid_attribute_register('physgrid', 'areawt', & - 'physics column area wts', 'ncol', areawt_d, map=grid_map(3,:)) - nullify(area_d) ! Belongs to attribute now - nullify(areawt_d) ! Belongs to attribute now - end if - ! Cleanup pointers (they belong to the grid now) - nullify(grid_map) - deallocate(latvals) - nullify(latvals) - deallocate(lonvals) - nullify(lonvals) - ! Cleanup, we are responsible for copy attributes - if (associated(copy_attributes)) then - deallocate(copy_attributes) - nullify(copy_attributes) - end if - - ! - physgrid_set = .true. ! Set flag indicating physics grid is now set - ! - call t_stopf("phys_grid_init") - - if (calc_memory_increase) then - call shr_mem_getusage(mem_hw_end, mem_end) - clat_p_tmp = mem_end - mem_beg - call MPI_reduce(clat_p_tmp, mem_end, 1, MPI_REAL8, MPI_MAX, & - masterprocid, mpicom, curp) - if (masterproc) then - write(iulog, *) 'phys_grid_init: Increase in memory usage = ', & - mem_end, ' (MB)' - end if - clat_p_tmp = mem_hw_end - mem_hw_beg - call MPI_reduce(clat_p_tmp, mem_hw_end, 1, MPI_REAL8, MPI_MAX, & - masterprocid, mpicom, curp) - if (masterproc) then - write(iulog, *) 'phys_grid_init: Increase in memory highwater = ', & - mem_end, ' (MB)' - end if - end if - - end subroutine phys_grid_init - -!======================================================================== - -subroutine phys_grid_find_col(lat, lon, owner, lcid, icol) - - !----------------------------------------------------------------------- - ! - ! Purpose: Find the global column closest to the point specified by lat - ! and lon. Return indices of owning process, local chunk, and - ! column. - ! - ! Authors: Phil Rasch / Patrick Worley / B. Eaton - ! - !----------------------------------------------------------------------- - - real(r8), intent(in) :: lat, lon ! requested location in degrees - integer, intent(out) :: owner ! rank of chunk owner - integer, intent(out) :: lcid ! local chunk index - integer, intent(out) :: icol ! column index within the chunk - - ! local - real(r8) dist2 ! the distance (in radians**2 from lat, lon) - real(r8) distmin ! the distance (in radians**2 from closest column) - real(r8) latr, lonr ! lat, lon (in radians) of requested location - real(r8) clat, clon ! lat, lon (in radians) of column being tested - real(r8) const - - integer i - integer cid - !----------------------------------------------------------------------- - - ! Check that input lat and lon are in valid range - if (lon < 0.0_r8 .or. lon >= 360._r8 .or. & - lat < -90._r8 .or. lat > 90._r8) then - if (masterproc) then - write(iulog,*) & - 'phys_grid_find_col: ERROR: lon must satisfy 0.<=lon<360. and lat must satisfy -90<=lat<=90.' - write(iulog,*) & - 'input lon=', lon, ' input lat=', lat - endif - call endrun('phys_grid_find_col: input ERROR') - end if - - const = 180._r8/pi ! degrees per radian - latr = lat/const ! to radians - lonr = lon/const ! to radians - - owner = -999 - lcid = -999 - icol = -999 - distmin = 1.e10_r8 - - ! scan all chunks for closest point to lat, lon - do cid = 1, nchunks - do i = 1, chunks(cid)%ncols - clat = clat_p(chunks(cid)%lat(i)) - clon = clon_p(chunks(cid)%lon(i)) - dist2 = (clat-latr)**2 + (clon-lonr)**2 - if (dist2 < distmin ) then - distmin = dist2 - owner = chunks(cid)%owner - lcid = chunks(cid)%lcid - icol = i - endif - enddo - end do - -end subroutine phys_grid_find_col - -!======================================================================== - -subroutine phys_grid_find_cols(lat, lon, nclosest, owner, lcid, icol, distmin, mlats, mlons) - - !----------------------------------------------------------------------- - ! - ! Purpose: Find the global columns closest to the point specified by lat - ! and lon. Return indices of owning process, local chunk, and - ! column. - ! - ! Authors: Phil Rasch / Patrick Worley / B. Eaton - ! - !----------------------------------------------------------------------- - use physconst, only : rearth - - real(r8), intent(in) :: lat, lon ! requested location in degrees - integer, intent(in) :: nclosest ! number of closest points to find - integer, intent(out) :: owner(nclosest) ! rank of chunk owner - integer, intent(out) :: lcid(nclosest) ! local chunk index - integer, intent(out) :: icol(nclosest) ! column index within the chunk - real(r8),intent(out) :: distmin(nclosest) ! the distance (m) of the closest column(s) - real(r8),intent(out) :: mlats(nclosest) ! the latitude of the closest column(s) - real(r8),intent(out) :: mlons(nclosest) ! the longitude of the closest column(s) - - ! local - real(r8) dist2 ! the distance (in radians**2 from lat, lon) - real(r8) latr, lonr ! lat, lon (in radians) of requested location - real(r8) clat, clon ! lat, lon (in radians) of column being tested - real(r8) const - - integer i, j - integer cid - !----------------------------------------------------------------------- - - ! Check that input lat and lon are in valid range - if (lon < 0.0_r8 .or. lon >= 360._r8 .or. & - lat < -90._r8 .or. lat > 90._r8) then - if (masterproc) then - write(iulog,*) & - 'phys_grid_find_cols: ERROR: lon must satisfy 0.<=lon<360. and lat must satisfy -90<=lat<=90.' - write(iulog,*) & - 'input lon=', lon, ' input lat=', lat - endif - call endrun('phys_grid_find_cols: input ERROR') - end if - - const = 180._r8/pi ! degrees per radian - latr = lat/const ! to radians - lonr = lon/const ! to radians - - owner(:) = -999 - lcid(:) = -999 - icol(:) = -999 - mlats(:) = -999 - mlons(:) = -999 - distmin(:) = 1.e10_r8 - - ! scan all chunks for closest point to lat, lon - do cid = 1, nchunks - do i = 1, chunks(cid)%ncols - clat = clat_p(chunks(cid)%lat(i)) - clon = clon_p(chunks(cid)%lon(i)) - dist2 = acos(sin(latr) * sin(clat) + cos(latr) * cos(clat) * cos(clon - lonr)) * rearth - - do j = nclosest, 1, -1 - if (dist2 < distmin(j)) then - - if (j < nclosest) then - distmin(j+1) = distmin(j) - owner(j+1) = owner(j) - lcid(j+1) = lcid(j) - icol(j+1) = icol(j) - mlats(j+1) = mlats(j) - mlons(j+1) = mlons(j) - end if + type(chunk), private, pointer :: chunks(:) => NULL() ! (begchunk:endchunk) - distmin(j) = dist2 - owner(j) = chunks(cid)%owner - lcid(j) = chunks(cid)%lcid - icol(j) = i - mlats(j) = clat * const - mlons(j) = clon * const - else - exit - end if - enddo - enddo - end do + logical :: phys_grid_set = .false. -end subroutine phys_grid_find_cols -! -!======================================================================== + logical :: calc_memory_increase = .false. -logical function phys_grid_initialized () -!----------------------------------------------------------------------- -! -! Purpose: Identify whether phys_grid has been called yet or not -! -! Method: Return physgrid_set -! -! Author: Pat Worley -! -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! - phys_grid_initialized = physgrid_set -! - return - end function phys_grid_initialized + interface get_dyn_col_p + module procedure :: get_dyn_col_p_chunk + module procedure :: get_dyn_col_p_index + end interface get_dyn_col_p -! -!======================================================================== -! - subroutine get_chunk_indices_p(index_beg, index_end) -!----------------------------------------------------------------------- -! -! Purpose: Return range of indices for local chunks -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(out) :: index_beg ! first index used for local chunks - integer, intent(out) :: index_end ! last index used for local chunks -!----------------------------------------------------------------------- + ! Private interfaces + private :: chunk_info_to_index_p - index_beg = begchunk - index_end = endchunk +!!XXgoldyXX: v temporary interface to allow old code to compile + interface get_lat_all_p + module procedure :: get_lat_all_p_r8 ! The new version + module procedure :: get_lat_all_p_int ! calls endun + end interface get_lat_all_p - return - end subroutine get_chunk_indices_p -! -!======================================================================== -! - subroutine get_gcol_all_p(lcid, latdim, gcols) -!----------------------------------------------------------------------- -! -! Purpose: Return all global column indices for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: latdim ! declared size of output array - - integer, intent(out) :: gcols(:) ! array of global latitude indices -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - -!----------------------------------------------------------------------- - gcols=-1 - do i=1,lchunks(lcid)%ncols - gcols(i) = lchunks(lcid)%gcol(i) - enddo - return - end subroutine get_gcol_all_p + interface get_lon_all_p + module procedure :: get_lon_all_p_r8 ! The new version + module procedure :: get_lon_all_p_int ! calls endun + end interface get_lon_all_p +!!XXgoldyXX: ^ temporary interface to allow old code to compile -! -!======================================================================== -! - integer function get_gcol_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return global physics column index for chunk column -! -! Method: -! -! Author: Jim Edwards / Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index -!----------------------------------------------------------------------- - get_gcol_p = lchunks(lcid)%gcol(col) + integer, protected, public :: pver = 0 + integer, protected, public :: pverp = 0 + integer, protected, public :: num_global_phys_cols = 0 + integer, protected, public :: columns_on_task = 0 + integer, protected, public :: index_top_layer = 0 + integer, protected, public :: index_bottom_layer = 0 + integer, protected, public :: index_top_interface = 1 + integer, protected, public :: index_bottom_interface = 0 + integer, public :: phys_columns_on_task = 0 - return - end function get_gcol_p +!============================================================================== +CONTAINS +!============================================================================== -! -!======================================================================== + subroutine phys_grid_readnl(nlfile) + use cam_abortutils, only: endrun + use namelist_utils, only: find_group_name + use cam_logfile, only: iulog + use spmd_utils, only: mpicom, mstrid=>masterprocid, masterproc + use spmd_utils, only: mpi_integer + use ppgrid, only: pcols - subroutine get_gcol_vec_p(lcid, lth, cols, gcols) -!----------------------------------------------------------------------- -! -! Purpose: Return global physics column indices for set of chunk columns -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid + character(len=*), intent(in) :: nlfile + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'phys_grid_readnl' -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: lth ! number of column indices - integer, intent(in) :: cols(lth) ! column indices + integer :: phys_alltoall = -HUGE(1) + integer :: phys_loadbalance = -HUGE(1) + integer :: phys_twin_algorithm = -HUGE(1) + integer :: phys_chnk_per_thd = -HUGE(1) - integer, intent(out) :: gcols(lth) ! array of global physics - ! columns indices + namelist /phys_grid_nl/ phys_alltoall, phys_loadbalance, & + phys_twin_algorithm, phys_chnk_per_thd + !------------------------------------------------------------------------ -!---------------------------Local workspace----------------------------- - integer :: i ! loop index + ! Read namelist + if (masterproc) then + open(newunit=unitn, file=trim(nlfile), status='old') + call find_group_name(unitn, 'phys_grid_nl', status=ierr) + if (ierr == 0) then + read(unitn, phys_grid_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub//': FATAL: reading namelist') + end if + end if + close(unitn) + end if -!----------------------------------------------------------------------- - do i=1,lth - gcols(i) = lchunks(lcid)%gcol(cols(i)) - enddo + call mpi_bcast(phys_alltoall, 1, mpi_integer, mstrid, mpicom, ierr) + call mpi_bcast(phys_loadbalance, 1, mpi_integer, mstrid, mpicom, ierr) + call mpi_bcast(phys_twin_algorithm, 1, mpi_integer, mstrid, mpicom, ierr) + call mpi_bcast(phys_chnk_per_thd, 1, mpi_integer, mstrid, mpicom, ierr) - return - end subroutine get_gcol_vec_p + if (masterproc) then + write(iulog,*) 'PHYS_GRID options:' + write(iulog,*) ' Using PCOLS =', pcols + write(iulog,*) ' phys_loadbalance = (not used)' + write(iulog,*) ' phys_twin_algorithm = (not used)' + write(iulog,*) ' phys_alltoall = (not used)' + write(iulog,*) ' chunks_per_thread = (not used)' + end if -! -!======================================================================== -! - integer function get_ncols_p(lcid) -!----------------------------------------------------------------------- -! -! Purpose: Return number of columns in chunk given the local chunk id. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id + end subroutine phys_grid_readnl + + !======================================================================== + + subroutine phys_grid_init() + use mpi, only: MPI_INTEGER, MPI_REAL8, MPI_MIN, MPI_MAX + use shr_mem_mod, only: shr_mem_getusage + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use spmd_utils, only: npes, mpicom, masterprocid, masterproc, iam + use ppgrid, only: pcols + use dyn_grid, only: get_dyn_grid_info, physgrid_copy_attributes_d + use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register + use cam_grid_support, only: iMap, hclen => max_hcoordname_len + use cam_grid_support, only: horiz_coord_t, horiz_coord_create + use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists + use shr_const_mod, only: PI => SHR_CONST_PI + use scamMod, only: scmlon,scmlat,single_column + + ! Local variables + integer :: index + integer :: col_index, phys_col + integer :: ichnk, icol, ncol, gcol + integer :: num_chunks + type(physics_column_t), allocatable :: dyn_columns(:) ! Dyn decomp + ! Maps and values for physics grid + real(r8), pointer :: lonvals(:) + real(r8), pointer :: latvals(:) + real(r8) :: lonmin, latmin + integer(iMap), pointer :: grid_map(:,:) + integer(iMap), allocatable :: coord_map(:) + type(horiz_coord_t), pointer :: lat_coord + type(horiz_coord_t), pointer :: lon_coord + real(r8), pointer :: area_d(:) + real(r8), pointer :: areawt_d(:) + real(r8) :: mem_hw_beg, mem_hw_end + real(r8) :: mem_beg, mem_end + logical :: unstructured + real(r8) :: temp ! For MPI + integer :: ierr ! For MPI + character(len=hclen), pointer :: copy_attributes(:) + character(len=hclen) :: copy_gridname + character(len=*), parameter :: subname = 'phys_grid_init: ' + real(r8), parameter :: rarea_sphere = 1.0_r8 / (4.0_r8*PI) + real (r8), allocatable :: dynlats(:),dynlons(:),pos_dynlons(:) + real (r8) :: pos_scmlon,minpoint,testpoint + integer :: scm_col_index, i + + nullify(lonvals) + nullify(latvals) + nullify(grid_map) + nullify(lat_coord) + nullify(lon_coord) + nullify(area_d) + nullify(areawt_d) + nullify(copy_attributes) -!---------------------------Local workspace----------------------------- - integer :: cid ! global chunk id + if (calc_memory_increase) then + call shr_mem_getusage(mem_hw_beg, mem_beg) + end if -!----------------------------------------------------------------------- - get_ncols_p = lchunks(lcid)%ncols + call t_adj_detailf(-2) + call t_startf("phys_grid_init") - return - end function get_ncols_p + ! Gather info from the dycore + call get_dyn_grid_info(hdim1_d, hdim2_d, pver, index_top_layer, & + index_bottom_layer, unstructured, dyn_columns) -!======================================================================== + ! Set up the physics decomposition + columns_on_task = size(dyn_columns) - subroutine get_grid_dims(hdim1_d_out, hdim2_d_out) - use cam_abortutils, only: endrun - ! retrieve dynamics field grid information - ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid - ! data structure, If 1D data structure, then hdim2_d == 1. - integer, intent(out) :: hdim1_d_out - integer, intent(out) :: hdim2_d_out + if (single_column) then + allocate(dynlats(columns_on_task),dynlons(columns_on_task),pos_dynlons(columns_on_task)) + dynlats(:) = dyn_columns(:)%lat_deg + dynlons(:) = dyn_columns(:)%lon_deg - if (.not. phys_grid_initialized()) then - call endrun('get_grid_dims: physics grid not initialized') + pos_dynlons(:)= mod(dynlons(:) + 360._r8,360._r8) + pos_scmlon = mod(scmlon + 360._r8,360._r8) + + if (unstructured) then + minpoint=1000.0 + do i=1,columns_on_task + testpoint=abs(pos_dynlons(i)-pos_scmlon)+abs(dynlats(i)-scmlat) + if (testpoint .lt. minpoint) then + minpoint=testpoint + scm_col_index=i + endif + enddo + else +!jt start(1) = (MINLOC(abs(pos_lons-pos_scmlon),dim=1)) +!jt start(2) = (MINLOC(abs(lats -scmlat ),dim=1)) + end if + hdim1_d = 1 + hdim2_d = 1 + phys_columns_on_task = 1 + deallocate(dynlats,dynlons,pos_dynlons) + else + phys_columns_on_task = columns_on_task + end if + ! hdim1_d * hdim2_d is the total number of columns + num_global_phys_cols = hdim1_d * hdim2_d + pverp = pver + 1 + !!XXgoldyXX: Can we enforce interface numbering separate from dycore? + !!XXgoldyXX: This will work for both CAM and WRF/MPAS physics + !!XXgoldyXX: This only has a 50% chance of working on a single level model + if (index_top_layer < index_bottom_layer) then + index_top_interface = index_top_layer + index_bottom_interface = index_bottom_layer + 1 + else + index_bottom_interface = index_bottom_layer + index_top_interface = index_top_layer + 1 end if - hdim1_d_out = hdim1_d - hdim2_d_out = hdim2_d - end subroutine get_grid_dims -! -!======================================================================== -! - subroutine get_lat_all_p(lcid, latdim, lats) -!----------------------------------------------------------------------- -! -! Purpose: Return all global latitude indices for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: latdim ! declared size of output array - - integer, intent(out) :: lats(latdim) ! array of global latitude indices - -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,chunks(cid)%ncols - lats(i) = chunks(cid)%lat(i) - enddo - - return - end subroutine get_lat_all_p -! -!======================================================================== + if (allocated(phys_columns)) then + deallocate(phys_columns) + end if + allocate(phys_columns(phys_columns_on_task)) + if (phys_columns_on_task > 0) then + col_index = phys_columns_on_task + num_chunks = col_index / pcols + if ((num_chunks * pcols) < col_index) then + num_chunks = num_chunks + 1 + end if + begchunk = 1 + endchunk = begchunk + num_chunks - 1 + else + ! We do not support tasks with no physics columns + call endrun(subname//'No columns on task, use fewer tasks') + end if + allocate(chunks(begchunk:endchunk)) + col_index = 0 + ! Simple chunk assignment + do index = begchunk, endchunk + chunks(index)%ncols = MIN(pcols, (phys_columns_on_task - col_index)) + chunks(index)%chunk_index = index + allocate(chunks(index)%phys_cols(chunks(index)%ncols)) + do phys_col = 1, chunks(index)%ncols + col_index = col_index + 1 + ! Copy information supplied by the dycore + if (single_column) then + phys_columns(col_index) = dyn_columns(scm_col_index) +!jt !scm physics only has 1 global column +!jt phys_columns(col_index)%global_col_num = 1 + else + phys_columns(col_index) = dyn_columns(col_index) + end if + ! Fill in physics decomp info + phys_columns(col_index)%coord_indicies(:)=scm_col_index + phys_columns(col_index)%phys_task = iam + phys_columns(col_index)%local_phys_chunk = index + phys_columns(col_index)%phys_chunk_index = phys_col + chunks(index)%phys_cols(phys_col) = col_index + end do + end do - subroutine get_lat_vec_p(lcid, lth, cols, lats) -!----------------------------------------------------------------------- -! -! Purpose: Return global latitude indices for set of chunk columns -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid + deallocate(dyn_columns) -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: lth ! number of column indices - integer, intent(in) :: cols(lth) ! column indices + ! Add physics-package grid to set of CAM grids + ! physgrid always uses 'lat' and 'lon' as coordinate names; If dynamics + ! grid is different, it will use different coordinate names - integer, intent(out) :: lats(lth) ! array of global latitude indices + ! First, create a map for the physics grid + ! It's structure will depend on whether or not the physics grid is + ! unstructured + if (unstructured) then + allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) + else + allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) + end if + grid_map = 0_iMap + allocate(latvals(size(grid_map, 2))) + allocate(lonvals(size(grid_map, 2))) + + lonmin = 1000.0_r8 ! Out of longitude range + latmin = 1000.0_r8 ! Out of latitude range + index = 0 + do ichnk = begchunk, endchunk + ncol = chunks(ichnk)%ncols ! Too soon to call get_ncols_p + do icol = 1, pcols + index = index + 1 + if (icol <= ncol) then + col_index = chunks(ichnk)%phys_cols(icol) + latvals(index) = phys_columns(col_index)%lat_deg + if (latvals(index) < latmin) then + latmin = latvals(index) + end if + lonvals(index) = phys_columns(col_index)%lon_deg + if (lonvals(index) < lonmin) then + lonmin = lonvals(index) + end if + else + col_index = -1 + latvals(index) = 1000.0_r8 + lonvals(index) = 1000.0_r8 + end if + grid_map(1, index) = int(icol, iMap) + grid_map(2, index) = int(ichnk, iMap) + if (icol <= ncol) then + if (unstructured) then + gcol = phys_columns%(col_index)%global_col_num + if (gcol > 0) then + grid_map(3, index) = int(gcol, iMap) + end if ! else entry remains 0 + else + ! lon + gcol = phys_columns(col_index)%coord_indices(1) + if (gcol > 0) then + grid_map(3, index) = int(gcol, iMap) + end if ! else entry remains 0 + ! lat + gcol = phys_columns(col_index)%coord_indices(2) + if (gcol > 0) then + grid_map(4, index) = gcol + end if ! else entry remains 0 + end if + end if ! Else entry remains 0 + end do + end do -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id + ! Note that if the dycore is using the same points as the physics grid, + ! it will have already set up 'lat' and 'lon' axes for + ! the physics grid + ! However, these will be in the dynamics decomposition + + if (unstructured) then + lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & + 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & + map=grid_map(3,:)) + lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & + 'latitude', 'degrees_north', 1, size(latvals), latvals, & + map=grid_map(3,:)) + else + allocate(coord_map(size(grid_map, 2))) + ! We need a global minimum longitude and latitude + if (npes > 1) then + temp = lonmin + call MPI_allreduce(temp, lonmin, 1, MPI_INTEGER, MPI_MIN, & + mpicom, ierr) + temp = latmin + call MPI_allreduce(temp, latmin, 1, MPI_INTEGER, MPI_MIN, & + mpicom, ierr) + ! Create lon coord map which only writes from one of each unique lon + where(latvals == latmin) + coord_map(:) = grid_map(3, :) + elsewhere + coord_map(:) = 0_iMap + end where + lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, & + 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & + map=coord_map) + + ! Create lat coord map which only writes from one of each unique lat + where(lonvals == lonmin) + coord_map(:) = grid_map(4, :) + elsewhere + coord_map(:) = 0_iMap + end where + lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, & + 'latitude', 'degrees_north', 1, size(latvals), latvals, & + map=coord_map) + deallocate(coord_map) + end if + end if + call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & + grid_map, unstruct=unstructured, block_indexed=.true.) + ! Copy required attributes from the dynamics array + nullify(copy_attributes) + call physgrid_copy_attributes_d(copy_gridname, copy_attributes) + do index = 1, size(copy_attributes) + call cam_grid_attribute_copy(copy_gridname, 'physgrid', & + copy_attributes(index)) + end do -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,lth - lats(i) = chunks(cid)%lat(cols(i)) - enddo + if (.not. cam_grid_attr_exists('physgrid', 'area')) then + ! Physgrid always needs an area attribute. + if (unstructured) then + ! If we did not inherit one from the dycore (i.e., physics and + ! dynamics are on different grids), create that attribute here + ! (Note, a separate physics grid is only supported for + ! unstructured grids). + allocate(area_d(size(grid_map, 2))) + do col_index = 1, phys_columns_on_task + area_d(col_index) = phys_columns(col_index)%area + end do + call cam_grid_attribute_register('physgrid', 'area', & + 'physics column areas', 'ncol', area_d, map=grid_map(3,:)) + nullify(area_d) ! Belongs to attribute now - return - end subroutine get_lat_vec_p -! -!======================================================================== + allocate(areawt_d(size(grid_map, 2))) + do col_index = 1, phys_columns_on_task + areawt_d(col_index) = phys_columns(col_index)%weight*rarea_sphere + end do + call cam_grid_attribute_register('physgrid', 'areawt', & + 'physics column area weight', 'ncol', areawt_d, map=grid_map(3,:)) + nullify(areawt_d) ! Belongs to attribute now + else + call endrun(subname//"No 'area' attribute from dycore") + end if + end if + ! Cleanup pointers (they belong to the grid now) + nullify(grid_map) + deallocate(latvals) + nullify(latvals) + deallocate(lonvals) + nullify(lonvals) + ! Cleanup, we are responsible for copy attributes + if (associated(copy_attributes)) then + deallocate(copy_attributes) + nullify(copy_attributes) + end if - integer function get_lat_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return global latitude index for chunk column -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index + ! Set flag indicating physics grid is now set + phys_grid_set = .true. -!---------------------------Local workspace----------------------------- - integer :: cid ! global chunk id + call t_stopf("phys_grid_init") + call t_adj_detailf(+2) -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - get_lat_p = chunks(cid)%lat(col) + if (calc_memory_increase) then + call shr_mem_getusage(mem_hw_end, mem_end) + temp = mem_end - mem_beg + call MPI_reduce(temp, mem_end, 1, MPI_REAL8, MPI_MAX, masterprocid, & + mpicom, ierr) + if (masterproc) then + write(iulog, *) 'phys_grid_init: Increase in memory usage = ', & + mem_end, ' (MB)' + end if + temp = mem_hw_end - mem_hw_beg + call MPI_reduce(temp, mem_hw_end, 1, MPI_REAL8, MPI_MAX, & + masterprocid, mpicom, ierr) + if (masterproc) then + write(iulog, *) subname, 'Increase in memory highwater = ', & + mem_end, ' (MB)' + end if + end if - return - end function get_lat_p -! -!======================================================================== -! - subroutine get_lon_all_p(lcid, londim, lons) -!----------------------------------------------------------------------- -! -! Purpose: -! Was: Return all global longitude indices for chunk -! Now: Return all longitude offsets (+1) for chunk. These are offsets -! in ordered list of global columns from first -! column with given latitude to column with given latitude -! and longitude. This corresponds to the usual longitude indices -! for full and reduced lon/lat grids. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: londim ! declared size of output array - - integer, intent(out) :: lons(londim) ! array of global longitude - ! indices - -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: lat ! latitude index - integer :: cid ! global chunk id - integer :: gcol ! global column id in latlon - ! ordering - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,chunks(cid)%ncols - lat = chunks(cid)%lat(i) - gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(i)) - lons(i) = (gcol - clat_p_idx(lat)) + 1 - enddo - - return - end subroutine get_lon_all_p -! -!======================================================================== + end subroutine phys_grid_init - subroutine get_lon_vec_p(lcid, lth, cols, lons) -!----------------------------------------------------------------------- -! -! Purpose: -! Was: Return global longitude indices for set of chunk columns. -! Now: Return longitude offsets (+1) for set of chunk columns. -! These are offsets in ordered list of global columns from first -! column with given latitude to column with given latitude -! and longitude. This corresponds to the usual longitude indices -! for full and reduced lon/lat grids. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: lth ! number of column indices - integer, intent(in) :: cols(lth) ! column indices - - integer, intent(out) :: lons(lth) ! array of global longitude indices - -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: lat ! latitude index - integer :: cid ! global chunk id - integer :: gcol ! global column id in latlon - ! ordering - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,lth - lat = chunks(cid)%lat(cols(i)) - gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(i)) - lons(i) = (gcol - clat_p_idx(lat)) + 1 - enddo - - return - end subroutine get_lon_vec_p -! -!======================================================================== + !======================================================================== - integer function get_lon_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: -! Was: Return global longitude index for chunk column. -! Now: Return longitude offset (+1) for chunk column. This is the -! offset in ordered list of global columns from first -! column with given latitude to column with given latitude -! and longitude. This corresponds to the usual longitude index -! for full and reduced lon/lat grids. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index - -!---------------------------Local workspace----------------------------- - integer :: cid ! global chunk id - integer :: lat ! latitude index - integer :: gcol ! global column id in latlon - ! ordering - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - lat = chunks(cid)%lat(col) - gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(col)) - get_lon_p = (gcol - clat_p_idx(lat)) + 1 - - return - end function get_lon_p -! -!======================================================================== -! - subroutine get_rlat_all_p(lcid, rlatdim, rlats) -!----------------------------------------------------------------------- -! -! Purpose: Return all latitudes (in radians) for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rlatdim ! declared size of output array + integer function chunk_info_to_index_p(lcid, col, subname_in) + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + ! Return the physics column index indicated by + ! (chunk) and (column). - real(r8), intent(out) :: rlats(rlatdim)! array of latitudes + ! Dummy arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! Column index + character(len=*), optional, intent(in) :: subname_in + ! Local variables + character(len=128) :: errmsg + character(len=*), parameter :: subname = 'chunk_info_to_index_p: ' -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id + if (.not. phys_grid_initialized()) then + if (present(subname_in)) then + call endrun(trim(subname_in)//'physics grid not initialized') + else + call endrun(subname//'physics grid not initialized') + end if + else if ((lcid < begchunk) .or. (lcid > endchunk)) then + if (present(subname_in)) then + write(errmsg, '(a,3(a,i0))') trim(subname_in), 'lcid (', lcid, & + ') out of range (', begchunk, ' to ', endchunk + else + write(errmsg, '(a,3(a,i0))') subname, 'lcid (', lcid, & + ') out of range (', begchunk, ' to ', endchunk + end if + write(iulog, *) trim(errmsg) + call endrun(trim(errmsg)) + else if ((col < 1) .or. (col > get_ncols_p(lcid))) then + if (present(subname_in)) then + write(errmsg, '(a,2(a,i0))') trim(subname_in), 'col (', col, & + ') out of range (1 to ', get_ncols_p(lcid) + else + write(errmsg, '(a,2(a,i0))') subname, 'col (', col, & + ') out of range (1 to ', get_ncols_p(lcid) + end if + write(iulog, *) trim(errmsg) + call endrun(trim(errmsg)) + end if + chunk_info_to_index_p = chunks(lcid)%phys_cols(col) + end function chunk_info_to_index_p -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,chunks(cid)%ncols - rlats(i) = clat_p(chunks(cid)%lat(i)) - enddo + !======================================================================== - return - end subroutine get_rlat_all_p -! -!======================================================================== -! - subroutine get_area_all_p(lcid, rdim, area) -!----------------------------------------------------------------------- -! -! Purpose: Return all areas for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rdim ! declared size of output array + logical function phys_grid_initialized() + ! Return .true. if the physics grid is initialized, otherwise .false. + phys_grid_initialized = phys_grid_set + end function phys_grid_initialized - real(r8), intent(out) :: area(rdim) ! array of areas + !======================================================================== -!---------------------------Local workspace----------------------------- - integer :: i ! loop index + integer function get_nlcols_p() + get_nlcols_p = phys_columns_on_task + end function get_nlcols_p -!----------------------------------------------------------------------- - do i=1,lchunks(lcid)%ncols - area(i) = lchunks(lcid)%area(i) - enddo + !======================================================================== - return - end subroutine get_area_all_p -! -!======================================================================== -! - real(r8) function get_area_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return area for chunk column -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index + real(r8) function get_rlat_p(lcid, col) + !----------------------------------------------------------------------- + ! + ! get_rlat_p: latitude of a physics column in radians + ! + !----------------------------------------------------------------------- + + ! Dummy argument + integer, intent(in) :: lcid + integer, intent(in) :: col + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_rlat_p' + + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_rlat_p = phys_columns(index)%lat_rad -!----------------------------------------------------------------------- - get_area_p = lchunks(lcid)%area(col) + end function get_rlat_p - return - end function get_area_p -! -!======================================================================== -! - subroutine get_wght_all_p(lcid, rdim, wght) -!----------------------------------------------------------------------- -! -! Purpose: Return all integration weights for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rdim ! declared size of output array + !======================================================================== - real(r8), intent(out) :: wght(rdim) ! array of integration weights + real(r8) function get_rlon_p(lcid, col) + !----------------------------------------------------------------------- + ! + ! get_rlon_p: longitude of a physics column in radians + ! + !----------------------------------------------------------------------- + + ! Dummy argument + integer, intent(in) :: lcid + integer, intent(in) :: col + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_rlon_p' + + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_rlon_p = phys_columns(index)%lon_rad -!---------------------------Local workspace----------------------------- - integer :: i ! loop index + end function get_rlon_p -!----------------------------------------------------------------------- - do i=1,lchunks(lcid)%ncols - wght(i) = lchunks(lcid)%wght(i) - enddo + !======================================================================== - return - end subroutine get_wght_all_p -! -!======================================================================== -! - real(r8) function get_wght_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return integration weight for chunk column -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index + subroutine get_rlat_all_p(lcid, rlatdim, rlats) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_rlat_all_p: Return all latitudes (in radians) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rlatdim ! declared size of output array + real(r8), intent(out) :: rlats(rlatdim) ! array of latitudes + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_rlat_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') + end if + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), rlatdim) + phys_ind = chunks(lcid)%phys_cols(index) + rlats(index) = phys_columns(phys_ind)%lat_rad + end do -!----------------------------------------------------------------------- - get_wght_p = lchunks(lcid)%wght(col) + end subroutine get_rlat_all_p - return - end function get_wght_p -! -!======================================================================== -! - subroutine get_rlat_vec_p(lcid, lth, cols, rlats) -!----------------------------------------------------------------------- -! -! Purpose: Return latitudes (in radians) for set of chunk columns -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: lth ! number of column indices - integer, intent(in) :: cols(lth) ! column indices - - real(r8), intent(out) :: rlats(lth) ! array of latitudes - -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,lth - rlats(i) = clat_p(chunks(cid)%lat(cols(i))) - enddo - - return - end subroutine get_rlat_vec_p -! -!======================================================================== + !======================================================================== - real(r8) function get_rlat_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return latitude (in radians) for chunk column -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index + subroutine get_rlon_all_p(lcid, rlondim, rlons) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_rlon_all_p:: Return all longitudes (in radians) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rlondim ! declared size of output array + real(r8), intent(out) :: rlons(rlondim) ! array of longitudes + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_rlon_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') + end if + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), rlondim) + phys_ind = chunks(lcid)%phys_cols(index) + rlons(index) = phys_columns(phys_ind)%lon_rad + end do -!---------------------------Local workspace----------------------------- - integer :: cid ! global chunk id + end subroutine get_rlon_all_p -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - get_rlat_p = clat_p(chunks(cid)%lat(col)) + !======================================================================== - return - end function get_rlat_p -! -!======================================================================== -! - subroutine get_rlon_all_p(lcid, rlondim, rlons) -!----------------------------------------------------------------------- -! -! Purpose: Return all longitudes (in radians) for chunk -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rlondim ! declared size of output array + real(r8) function get_lat_p(lcid, col) + !----------------------------------------------------------------------- + ! + ! get_lat_p: latitude of a physics column in degrees + ! + !----------------------------------------------------------------------- - real(r8), intent(out) :: rlons(rlondim)! array of longitudes + ! Dummy argument + integer, intent(in) :: lcid + integer, intent(in) :: col + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_lat_p' -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_lat_p = phys_columns(index)%lat_deg -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,chunks(cid)%ncols - rlons(i) = clon_p(chunks(cid)%lon(i)) - enddo + end function get_lat_p - return - end subroutine get_rlon_all_p -! -!======================================================================== + !======================================================================== - subroutine get_rlon_vec_p(lcid, lth, cols, rlons) -!----------------------------------------------------------------------- -! -! Purpose: Return longitudes (in radians) for set of chunk columns -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: lth ! number of column indices - integer, intent(in) :: cols(lth) ! column indices - - real(r8), intent(out) :: rlons(lth) ! array of longitudes - -!---------------------------Local workspace----------------------------- - integer :: i ! loop index - integer :: cid ! global chunk id - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - do i=1,lth - rlons(i) = clon_p(chunks(cid)%lon(cols(i))) - enddo - - return - end subroutine get_rlon_vec_p -! -!======================================================================== + real(r8) function get_lon_p(lcid, col) + !----------------------------------------------------------------------- + ! + ! get_lon_p: longitude of a physics column in degrees + ! + !----------------------------------------------------------------------- - real(r8) function get_rlon_p(lcid, col) -!----------------------------------------------------------------------- -! -! Purpose: Return longitude (in radians) for chunk column -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use ppgrid -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index - -!---------------------------Local workspace----------------------------- - integer :: cid ! global chunk id - -!----------------------------------------------------------------------- - cid = lchunks(lcid)%cid - get_rlon_p = clon_p(chunks(cid)%lon(col)) - - return - end function get_rlon_p -! -!======================================================================== -! - - subroutine scatter_field_to_chunk(fdim,mdim,ldim, & - hdim1d,globalfield,localchunks) -!----------------------------------------------------------------------- -! -! Purpose: Distribute field -! to decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! - -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - real(r8), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - ! global field - - real(r8), intent(out):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - ! local chunks - -!---------------------------Local workspace----------------------------- - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - real(r8) gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be scattered - real(r8) lfield_p(fdim,mdim,ldim,nlcols) - ! local component of scattered - ! vector - integer :: displs(0:npes-1) ! scatter displacements - integer :: sndcnts(0:npes-1) ! scatter send counts - integer :: recvcnt ! scatter receive count - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - write(iulog,*) __FILE__,__LINE__,hdim1d,hdim1_d - call endrun ('SCATTER_FIELD_TO_CHUNK error: hdim1d < hdim1_d') - endif - localchunks(:,:,:,:,:) = 0 -#if ( defined SPMD ) - displs(0) = 0 - sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + sndcnts(p-1) - sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - recvcnt = fdim*mdim*ldim*nlcols - - if (masterproc) then - -! copy field into global (process-ordered) chunked data structure - - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - gfield_p(f,m,l,i) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do - endif - -! scatter to other processes -! (pgcols ordering consistent with begchunk:endchunk -! local ordering) - - call t_barrierf('sync_scat_ftoc', mpicom) - call mpiscatterv(gfield_p, sndcnts, displs, mpir8, & - lfield_p, recvcnt, mpir8, 0, mpicom) - -! copy into local chunked data structure - - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do l=1,ldim - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - lfield_p(f, m, l, i) - end do - end do - end do - end do -#else - -! copy field into chunked data structure -! (pgcol ordering chosen to reflect begchunk:endchunk -! local ordering) - - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do - -#endif - - return - end subroutine scatter_field_to_chunk -!======================================================================== - - subroutine scatter_field_to_chunk4(fdim,mdim,ldim, & - hdim1d,globalfield,localchunks) -!----------------------------------------------------------------------- -! -! Purpose: Distribute field -! to decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - real(r4), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - ! global field - - real(r4), intent(out):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - ! local chunks - -!---------------------------Local workspace----------------------------- - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - real(r4) gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be scattered - real(r4) lfield_p(fdim,mdim,ldim,nlcols) - ! local component of scattered - ! vector - integer :: displs(0:npes-1) ! scatter displacements - integer :: sndcnts(0:npes-1) ! scatter send counts - integer :: recvcnt ! scatter receive count - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - call endrun ('SCATTER_FIELD_TO_CHUNK4 error: hdim1d < hdim1_d') - endif -#if ( defined SPMD ) - displs(0) = 0 - sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + sndcnts(p-1) - sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - recvcnt = fdim*mdim*ldim*nlcols - - if (masterproc) then - ! copy field into global (process-ordered) chunked data structure - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - gfield_p(f,m,l,i) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do - endif - -! scatter to other processes -! (pgcols ordering consistent with begchunk:endchunk -! local ordering) - - call t_barrierf('sync_scat_ftoc', mpicom) - call mpiscatterv(gfield_p, sndcnts, displs, mpir4, & - lfield_p, recvcnt, mpir4, 0, mpicom) - -! copy into local chunked data structure - - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do l=1,ldim - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - lfield_p(f, m, l, i) - end do - end do - end do - end do -#else - - ! copy field into chunked data structure - ! (pgcol ordering chosen to reflect begchunk:endchunk - ! local ordering) - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do + ! Dummy argument + integer, intent(in) :: lcid + integer, intent(in) :: col + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_lon_p' -#endif - - return - end subroutine scatter_field_to_chunk4 -!======================================================================== - - subroutine scatter_field_to_chunk_int(fdim,mdim,ldim, & - hdim1d,globalfield,localchunks) -!----------------------------------------------------------------------- -! -! Purpose: Distribute field -! to decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - integer, intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - ! global field - - integer, intent(out):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - ! local chunks - -!---------------------------Local workspace----------------------------- - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - integer gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be scattered - integer lfield_p(fdim,mdim,ldim,nlcols) - ! local component of scattered - ! vector - integer :: displs(0:npes-1) ! scatter displacements - integer :: sndcnts(0:npes-1) ! scatter send counts - integer :: recvcnt ! scatter receive count - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - call endrun ('SCATTER_FIELD_TO_CHUNK_INT error: hdim1d < hdim1_d') - endif -#if ( defined SPMD ) - displs(0) = 0 - sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + sndcnts(p-1) - sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - recvcnt = fdim*mdim*ldim*nlcols - - if (masterproc) then - -! copy field into global (process-ordered) chunked data structure - - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - gfield_p(f,m,l,i) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do - endif - -! scatter to other processes -! (pgcols ordering consistent with begchunk:endchunk -! local ordering) - - call t_barrierf('sync_scat_ftoc', mpicom) - call mpiscatterv(gfield_p, sndcnts, displs, mpiint, & - lfield_p, recvcnt, mpiint, 0, mpicom) - -! copy into local chunked data structure - - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do l=1,ldim - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - lfield_p(f, m, l, i) - end do - end do - end do - end do -#else - -! copy field into chunked data structure -! (pgcol ordering chosen to reflect begchunk:endchunk -! local ordering) - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - localchunks(f,lid,m,lcid,l) = & - globalfield(f, h1, m, h2, l) - end do - end do - end do - end do + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_lon_p = phys_columns(index)%lon_deg -#endif + end function get_lon_p - return - end subroutine scatter_field_to_chunk_int -! -!======================================================================== -! - subroutine gather_chunk_to_field(fdim,mdim,ldim, & - hdim1d,localchunks,globalfield) + !======================================================================== -!----------------------------------------------------------------------- -! -! Purpose: Reconstruct field -! from decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -#if ( defined SPMD ) - use spmd_utils, only: fc_gatherv -#endif -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - real(r8), intent(in):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - ! local chunks - - real(r8), intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - ! global field - -!---------------------------Local workspace----------------------------- - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - real(r8) gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be gathered - real(r8) lfield_p(fdim,mdim,ldim,nlcols) - ! local component of gather - ! vector - integer :: displs(0:npes-1) ! gather displacements - integer :: rcvcnts(0:npes-1) ! gather receive count - integer :: sendcnt ! gather send counts - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - call endrun ('GATHER_CHUNK_TO_FIELD error: hdim1d < hdim1_d') - endif -#if ( defined SPMD ) - displs(0) = 0 - rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + rcvcnts(p-1) - rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - sendcnt = fdim*mdim*ldim*nlcols - -! copy into local gather data structure - - do l=1,ldim - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do m=1,mdim - do f=1,fdim - lfield_p(f, m, l, i) = & - localchunks(f,lid,m,lcid,l) - end do - end do - end do - end do - -! gather from other processes - - call t_barrierf('sync_gath_ctof', mpicom) - call fc_gatherv(lfield_p, sendcnt, mpir8, & - gfield_p, rcvcnts, displs, mpir8, 0, mpicom) - - if (masterproc) then - -! copy gathered columns into lon/lat field - - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do l=1,ldim - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = gfield_p(f,m,l,i) - end do - end do - end do - end do - endif - call mpibarrier(mpicom) -#else - - ! copy chunked data structure into dynamics field - ! (pgcol ordering chosen to reflect begchunk:endchunk - ! local ordering) - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = localchunks(f,lid,m,lcid,l) - end do - end do + subroutine get_lat_all_p_r8(lcid, latdim, lats) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_lat_all_p: Return all latitudes (in degrees) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: latdim ! declared size of output array + real(r8), intent(out) :: lats(latdim) ! array of latitudes + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_lat_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') + end if + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), latdim) + phys_ind = chunks(lcid)%phys_cols(index) + lats(index) = phys_columns(phys_ind)%lat_deg end do - end do -#endif + end subroutine get_lat_all_p_r8 - return - end subroutine gather_chunk_to_field + !======================================================================== -! -!======================================================================== -! - subroutine gather_chunk_to_field4 (fdim,mdim,ldim, & - hdim1d,localchunks,globalfield) - -!----------------------------------------------------------------------- -! -! Purpose: Reconstruct field -! from decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -#if ( defined SPMD ) - use spmd_utils, only: fc_gathervr4 -#endif -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - real(r4), intent(in):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - ! local chunks - - real(r4), intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - ! global field - -!---------------------------Local workspace----------------------------- - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - real(r4) gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be gathered - real(r4) lfield_p(fdim,mdim,ldim,nlcols) - ! local component of gather - ! vector - integer :: displs(0:npes-1) ! gather displacements - integer :: rcvcnts(0:npes-1) ! gather receive count - integer :: sendcnt ! gather send counts - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - call endrun ('GATHER_CHUNK_TO_FIELD4 error: hdim1d < hdim1_d') - endif -#if ( defined SPMD ) - displs(0) = 0 - rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + rcvcnts(p-1) - rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - sendcnt = fdim*mdim*ldim*nlcols - -! copy into local gather data structure - - do l=1,ldim - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do m=1,mdim - do f=1,fdim - lfield_p(f, m, l, i) = & - localchunks(f,lid,m,lcid,l) - end do - end do - end do - end do - -! gather from other processes - - call t_barrierf('sync_gath_ctof', mpicom) - call fc_gathervr4(lfield_p, sendcnt, mpir4, & - gfield_p, rcvcnts, displs, mpir4, 0, mpicom) - - if (masterproc) then - -! copy gathered columns into lon/lat field - - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do l=1,ldim - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = gfield_p(f,m,l,i) - end do - end do - end do - end do - endif - -#else - -! copy chunked data structure into dynamics field -! (pgcol ordering chosen to reflect begchunk:endchunk -! local ordering) - - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = localchunks(f,lid,m,lcid,l) - end do - end do + subroutine get_lon_all_p_r8(lcid, londim, lons) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_lon_all_p:: Return all longitudes (in degrees) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: londim ! declared size of output array + real(r8), intent(out) :: lons(londim) ! array of longitudes + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_lon_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') + end if + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), londim) + phys_ind = chunks(lcid)%phys_cols(index) + lons(index) = phys_columns(phys_ind)%lon_deg end do - end do -#endif + end subroutine get_lon_all_p_r8 - return - end subroutine gather_chunk_to_field4 + !======================================================================== -! -!======================================================================== -! - subroutine gather_chunk_to_field_int (fdim,mdim,ldim, & - hdim1d,localchunks,globalfield) - -!----------------------------------------------------------------------- -! -! Purpose: Reconstruct field -! from decomposed chunk data structure -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -#if ( defined SPMD ) - use spmd_utils, only: fc_gathervint -#endif -!------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - ! dimension - integer, intent(in):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks - - integer, intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) ! global field - -!---------------------------Local workspace----------------------------- - - integer :: f,i,m,l,p ! loop indices - integer :: cid ! global chunk id - integer :: lcid ! local chunk id - integer :: lid ! local column index - integer :: gcol ! global column index - integer :: h1 ! first horizontal dimension index - integer :: h2 ! second horizontal dimension index - -#if ( defined SPMD ) - integer gfield_p(fdim,mdim,ldim,ngcols) - ! vector to be gathered - integer lfield_p(fdim,mdim,ldim,nlcols) - ! local component of gather - ! vector - integer :: displs(0:npes-1) ! gather displacements - integer :: rcvcnts(0:npes-1) ! gather receive count - integer :: sendcnt ! gather send counts - integer :: beglcol ! beginning index for local columns - ! in global column ordering -#endif - -!----------------------------------------------------------------------- - if (hdim1d < hdim1_d) then - call endrun ('GATHER_CHUNK_TO_FIELD_INT error: hdim1d < hdim1_d') - endif -#if ( defined SPMD ) - displs(0) = 0 - rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) - beglcol = 0 - do p=1,npes-1 - displs(p) = displs(p-1) + rcvcnts(p-1) - rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) - if (p <= iam) then - beglcol = beglcol + gs_col_num(p-1) - endif - enddo - sendcnt = fdim*mdim*ldim*nlcols - -! copy into local gather data structure - - do l=1,ldim - do i=1,nlcols - cid = pgcols(beglcol+i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(beglcol+i)%ccol - do m=1,mdim - do f=1,fdim - lfield_p(f, m, l, i) = & - localchunks(f,lid,m,lcid,l) - end do - end do - end do - end do - -! gather from other processes - - call t_barrierf('sync_gath_ctof', mpicom) - call fc_gathervint(lfield_p, sendcnt, mpiint, & - gfield_p, rcvcnts, displs, mpiint, 0, mpicom) - - if (masterproc) then - -! copy gathered columns into lon/lat field - - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do l=1,ldim - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = gfield_p(f,m,l,i) - end do - end do - end do - end do - endif - -#else - - ! copy chunked data structure into lon/lat field - ! (pgcol ordering chosen to reflect begchunk:endchunk - ! local ordering) - do l=1,ldim - do i=1,num_global_phys_cols - cid = pgcols(i)%chunk - lcid = chunks(cid)%lcid - lid = pgcols(i)%ccol - gcol = chunks(cid)%gcol(lid) - h2 = (gcol-1)/hdim1_d + 1 - h1 = mod((gcol-1),hdim1_d) + 1 - do m=1,mdim - do f=1,fdim - globalfield(f, h1, m, h2, l) & - = localchunks(f,lid,m,lcid,l) - end do - end do + subroutine get_area_all_p(lcid, areadim, areas) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_area_all_p: Return all areas for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: areadim ! declared size of output array + real(r8), intent(out) :: areas(areadim) ! array of areas + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_area_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') + end if + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), areadim) + phys_ind = chunks(lcid)%phys_cols(index) + areas(index) = phys_columns(phys_ind)%area end do - end do - -#endif - return - end subroutine gather_chunk_to_field_int - -! -!======================================================================== -! - subroutine write_field_from_chunk(iu,fdim,mdim,ldim,localchunks) - -!----------------------------------------------------------------------- -! -! -! Purpose: Write field from decomposed chunk data -! structure -! -! Method: -! -! Author: Patrick Worley -! -!------------------------------Arguments-------------------------------- - integer, intent(in) :: iu ! logical unit - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - real(r8), intent(in):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks - -!---------------------------Local workspace----------------------------- - - integer :: ioerr ! error return - - real(r8), allocatable :: globalfield(:,:,:,:,:) - ! global field -!----------------------------------------------------------------------- - - allocate(globalfield(fdim,hdim1_d,mdim,hdim2_d,ldim)) + end subroutine get_area_all_p - call gather_chunk_to_field (fdim,mdim,ldim,hdim1_d,localchunks,globalfield) + !======================================================================== - if (masterproc) then - write (iu,iostat=ioerr) globalfield - if (ioerr /= 0 ) then - write(iulog,*) 'WRITE_FIELD_FROM_CHUNK ioerror ', ioerr,' on i/o unit = ',iu - call endrun + subroutine get_wght_all_p(lcid, wghtdim, wghts) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_wght_all_p: Return all weights for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: wghtdim ! declared size of output array + real(r8), intent(out) :: wghts(wghtdim) ! array of weights + + ! Local variables + integer :: index ! loop index + integer :: phys_ind + character(len=*), parameter :: subname = 'get_wght_all_p: ' + + !----------------------------------------------------------------------- + if ((lcid < begchunk) .or. (lcid > endchunk)) then + call endrun(subname//'chunk index out of range') end if - endif - - deallocate(globalfield) - - return - end subroutine write_field_from_chunk - -! -!======================================================================== -! - subroutine read_chunk_from_field(iu,fdim,mdim,ldim,localchunks) - -!----------------------------------------------------------------------- -! -! -! Purpose: Write field from decomposed chunk data -! structure -! -! Method: -! -! Author: Patrick Worley -! -!------------------------------Arguments-------------------------------- - integer, intent(in) :: iu ! logical unit - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - - real(r8), intent(out):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks - -!---------------------------Local workspace----------------------------- + do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), wghtdim) + phys_ind = chunks(lcid)%phys_cols(index) + wghts(index) = phys_columns(phys_ind)%weight + end do - integer :: ioerr ! error return + end subroutine get_wght_all_p - real(r8), allocatable :: globalfield(:,:,:,:,:) - ! global field -!----------------------------------------------------------------------- + !======================================================================== - allocate(globalfield(fdim,hdim1_d,mdim,hdim2_d,ldim)) + integer function get_ncols_p(lcid, subname_in) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_ncols_p: Return number of columns in chunk given the local chunk id. + ! + !----------------------------------------------------------------------- + ! Dummy arguments + integer, intent(in) :: lcid ! local chunk id + character(len=*), optional, intent(in) :: subname_in - if (masterproc) then - read (iu,iostat=ioerr) globalfield - if (ioerr /= 0 ) then - write(iulog,*) 'READ_CHUNK_FROM_FIELD ioerror ', ioerr,' on i/o unit = ',iu - call endrun + if (.not. phys_grid_initialized()) then + if (present(subname_in)) then + call endrun(trim(subname_in)//'physics grid not initialized') + else + call endrun('get_ncols_p: physics grid not initialized') + end if + else + get_ncols_p = chunks(lcid)%ncols end if - endif - call scatter_field_to_chunk (fdim,mdim,ldim,hdim1_d,globalfield,localchunks) + end function get_ncols_p - deallocate(globalfield) + !======================================================================== - return - end subroutine read_chunk_from_field -! -!======================================================================== + real(r8) function get_area_p(lcid, col) + ! area of a physics column in radians squared - subroutine transpose_block_to_chunk(record_size, block_buffer, & - chunk_buffer, window) + ! Dummy arguments + integer, intent(in) :: lcid ! Chunk number + integer, intent(in) :: col ! column + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_area_p' -!----------------------------------------------------------------------- -! -! Purpose: Transpose buffer containing decomposed -! fields to buffer -! containing decomposed chunk data structures -! -! Method: -! -! Author: Patrick Worley -! Modified: Art Mirin, Jan 04, to add support for mod_comm -! -!----------------------------------------------------------------------- -#if ( defined SPMD ) -# if defined(MODCM_DP_TRANSPOSE) - use mod_comm, only: blockdescriptor, mp_sendirr, mp_recvirr, & - get_partneroffset, max_nparcels - use mpishorthand, only : mpicom -# endif - use spmd_utils, only: altalltoallv -#endif -!------------------------------Parameters------------------------------- -! - integer, parameter :: msgtag = 6000 -!------------------------------Arguments-------------------------------- - integer, intent(in) :: record_size ! per column amount of data - real(r8), intent(in) :: block_buffer(record_size*block_buf_nrecs) - ! buffer of block data to be - ! transposed - real(r8), intent(out):: chunk_buffer(record_size*chunk_buf_nrecs) - ! buffer of chunk data - ! transposed into - integer, intent(in), optional :: window - ! MPI-2 window id for - ! chunk_buffer - -!---------------------------Local workspace----------------------------- -#if ( defined SPMD ) - integer :: p ! loop indices - integer :: bbuf_siz ! size of block_buffer - integer :: cbuf_siz ! size of chunk_buffer - integer :: lwindow ! placeholder for missing window - integer :: lopt ! local copy of phys_alltoall -! - logical, save :: first = .true. - integer, allocatable, save :: sndcnts(:), sdispls(:) - integer, allocatable, save :: rcvcnts(:), rdispls(:) - integer, allocatable, save :: pdispls(:) - integer, save :: prev_record_size = 0 -# if defined(MODCM_DP_TRANSPOSE) - type (blockdescriptor), allocatable, save :: sendbl(:), recvbl(:) - integer ione, ierror, mod_method -# endif -!----------------------------------------------------------------------- - if (first) then -! Compute send/recv/put counts and displacements - allocate(sndcnts(0:npes-1)) - allocate(sdispls(0:npes-1)) - allocate(rcvcnts(0:npes-1)) - allocate(rdispls(0:npes-1)) - allocate(pdispls(0:npes-1)) -! -# if defined(MODCM_DP_TRANSPOSE) -! This branch uses mod_comm. Admissable values of phys_alltoall are -! 11,12 and 13. Each value corresponds to a different option -! within mod_comm of implementing the communication. That option is expressed -! internally to mod_comm using the variable mod_method defined below; -! mod_method will have values 0,1 or 2 and is defined as -! phys_alltoall - modmin_alltoall, where modmin_alltoall equals 11. -! Also, sendbl and recvbl must have exactly npes elements, to match -! this size of the communicator, or the transpose will fail. -! - if (phys_alltoall >= modmin_alltoall) then - mod_method = phys_alltoall - modmin_alltoall - ione = 1 - allocate( sendbl(0:npes-1) ) - allocate( recvbl(0:npes-1) ) + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_area_p = phys_columns(index)%area - do p = 0,npes-1 + end function get_area_p - sendbl(p)%method = mod_method - recvbl(p)%method = mod_method + !======================================================================== - allocate( sendbl(p)%blocksizes(1) ) - allocate( sendbl(p)%displacements(1) ) - allocate( recvbl(p)%blocksizes(1) ) - allocate( recvbl(p)%displacements(1) ) + real(r8) function get_wght_p(lcid, col) + ! weight of a physics column in radians squared - enddo + ! Dummy arguments + integer, intent(in) :: lcid ! Chunk number + integer, intent(in) :: col ! column + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_wght_p' - endif -# endif + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_wght_p = phys_columns(index)%weight - first = .false. - endif -! - if (record_size /= prev_record_size) then -! -! Compute send/recv/put counts and displacements - sdispls(0) = 0 - sndcnts(0) = record_size*btofc_blk_num(0) - do p=1,npes-1 - sdispls(p) = sdispls(p-1) + sndcnts(p-1) - sndcnts(p) = record_size*btofc_blk_num(p) - enddo -! - rdispls(0) = 0 - rcvcnts(0) = record_size*btofc_chk_num(0) - do p=1,npes-1 - rdispls(p) = rdispls(p-1) + rcvcnts(p-1) - rcvcnts(p) = record_size*btofc_chk_num(p) - enddo -! - call mpialltoallint(rdispls, 1, pdispls, 1, mpicom) -! -# if defined(MODCM_DP_TRANSPOSE) - if (phys_alltoall >= modmin_alltoall) then - do p = 0,npes-1 - - sendbl(p)%type = MPI_DATATYPE_NULL - if ( sndcnts(p) /= 0 ) then - - if (phys_alltoall > modmin_alltoall) then - call MPI_TYPE_INDEXED(ione, sndcnts(p), & - sdispls(p), mpir8, & - sendbl(p)%type, ierror) - call MPI_TYPE_COMMIT(sendbl(p)%type, ierror) - endif - - sendbl(p)%blocksizes(1) = sndcnts(p) - sendbl(p)%displacements(1) = sdispls(p) - sendbl(p)%partneroffset = 0 + end function get_wght_p - else + !======================================================================== - sendbl(p)%blocksizes(1) = 0 - sendbl(p)%displacements(1) = 0 - sendbl(p)%partneroffset = 0 + integer function get_gcol_p(lcid, col) + ! global column index of a physics column - endif - sendbl(p)%nparcels = size(sendbl(p)%displacements) - sendbl(p)%tot_size = sum(sendbl(p)%blocksizes) - max_nparcels = max(max_nparcels, sendbl(p)%nparcels) + ! Dummy arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index + ! Local variables + integer :: index + character(len=*), parameter :: subname = 'get_gcol_p: ' - recvbl(p)%type = MPI_DATATYPE_NULL - if ( rcvcnts(p) /= 0) then + index = chunk_info_to_index_p(lcid, col, subname_in=subname) + get_gcol_p = phys_columns(index)%global_col_num - if (phys_alltoall > modmin_alltoall) then - call MPI_TYPE_INDEXED(ione, rcvcnts(p), & - rdispls(p), mpir8, & - recvbl(p)%type, ierror) - call MPI_TYPE_COMMIT(recvbl(p)%type, ierror) - endif + end function get_gcol_p - recvbl(p)%blocksizes(1) = rcvcnts(p) - recvbl(p)%displacements(1) = rdispls(p) - recvbl(p)%partneroffset = 0 ! not properly initialized - do not use Mpi2 - else + !======================================================================== - recvbl(p)%blocksizes(1) = 0 - recvbl(p)%displacements(1) = 0 - recvbl(p)%partneroffset = 0 + subroutine get_dyn_col_p_chunk(lcid, col, blk_num, blk_ind, caller) + use cam_abortutils, only: endrun + ! Return the dynamics local block number and block offset(s) for + ! the physics column indicated by (chunk) and (column). + + ! Dummy arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! Column index + integer, intent(out) :: blk_num ! Local dynamics block index + integer, intent(out) :: blk_ind(:) ! Local dynamics block offset(s) + character(len=*), optional, intent(in) :: caller ! Calling routine + ! Local variables + integer :: index + integer :: off_size + character(len=*), parameter :: subname = 'get_dyn_col_p_chunk: ' + + index = chunk_info_to_index_p(lcid, col) + off_size = SIZE(phys_columns(index)%dyn_block_index, 1) + if (SIZE(blk_ind, 1) < off_size) then + if (present(caller)) then + call endrun(trim(caller)//': blk_ind too small') + else + call endrun(subname//'blk_ind too small') + end if + end if + blk_num = phys_columns(index)%local_dyn_block + blk_ind(1:off_size) = phys_columns(index)%dyn_block_index(1:off_size) + if (SIZE(blk_ind, 1) > off_size) then + blk_ind(off_size+1:) = -1 + end if - endif - recvbl(p)%nparcels = size(recvbl(p)%displacements) - recvbl(p)%tot_size = sum(recvbl(p)%blocksizes) - max_nparcels = max(max_nparcels, recvbl(p)%nparcels) + end subroutine get_dyn_col_p_chunk - enddo + !======================================================================== - call get_partneroffset(mpicom, sendbl, recvbl) + subroutine get_dyn_col_p_index(index, blk_num, blk_ind) + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + ! Return the dynamics local block number and block offset(s) for + ! the physics column indicated by . + + ! Dummy arguments + integer, intent(in) :: index ! index of local physics column + integer, intent(out) :: blk_num ! Local dynamics block index + integer, intent(out) :: blk_ind(:) ! Local dynamics block offset(s) + ! Local variables + integer :: off_size + character(len=128) :: errmsg + character(len=*), parameter :: subname = 'get_dyn_col_p_index: ' - endif -# endif -! - prev_record_size = record_size - endif -! - call t_barrierf('sync_tran_btoc', mpicom) - if (phys_alltoall < 0) then - if ((max_nproc_smpx > npes/2) .and. (nproc_busy_d > npes/2)) then - lopt = 0 - else - lopt = 1 - endif - else - lopt = phys_alltoall - if ((lopt == 2) .and. ( .not. present(window) )) lopt = 1 - endif - if (lopt < 4) then -! - bbuf_siz = record_size*block_buf_nrecs - cbuf_siz = record_size*chunk_buf_nrecs - if ( present(window) ) then - call altalltoallv(lopt, iam, npes, & - dp_coup_steps, dp_coup_proc, & - block_buffer, bbuf_siz, sndcnts, sdispls, mpir8, & - chunk_buffer, cbuf_siz, rcvcnts, rdispls, mpir8, & - msgtag, pdispls, mpir8, window, mpicom) + if (.not. phys_grid_initialized()) then + call endrun(subname//'physics grid not initialized') + else if ((index < 1) .or. (index > columns_on_task)) then + write(errmsg, '(a,2(a,i0))') subname, 'index (', index, & + ') out of range (1 to ', columns_on_task + write(iulog, *) trim(errmsg) + call endrun(trim(errmsg)) else - call altalltoallv(lopt, iam, npes, & - dp_coup_steps, dp_coup_proc, & - block_buffer, bbuf_siz, sndcnts, sdispls, mpir8, & - chunk_buffer, cbuf_siz, rcvcnts, rdispls, mpir8, & - msgtag, pdispls, mpir8, lwindow, mpicom) - endif -! - else -! -# if defined(MODCM_DP_TRANSPOSE) - call mp_sendirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) - call mp_recvirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) -# else - call mpialltoallv(block_buffer, sndcnts, sdispls, mpir8, & - chunk_buffer, rcvcnts, rdispls, mpir8, & - mpicom) -# endif -! - endif -! -#endif - return - end subroutine transpose_block_to_chunk -! -!======================================================================== - - subroutine block_to_chunk_send_pters(blockid, fdim, ldim, & - record_size, pter) -!----------------------------------------------------------------------- -! -! Purpose: Return pointers into send buffer where column from decomposed -! fields should be copied to -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: blockid ! block index - integer, intent(in) :: fdim ! first dimension of pter array - integer, intent(in) :: ldim ! last dimension of pter array - integer, intent(in) :: record_size ! per coordinate amount of data - - integer, intent(out) :: pter(fdim,ldim) ! buffer offsets -!---------------------------Local workspace----------------------------- - integer :: i, k ! loop indices -!----------------------------------------------------------------------- - if ((btofc_blk_offset(blockid)%ncols > fdim) .or. & - (btofc_blk_offset(blockid)%nlvls > ldim)) then - write(iulog,*) "BLOCK_TO_CHUNK_SEND_PTERS: pter array dimensions ", & - "not large enough: (",fdim,",",ldim,") not >= (", & - btofc_blk_offset(blockid)%ncols,",", & - btofc_blk_offset(blockid)%nlvls,")" - call endrun() - endif -! - do k=1,btofc_blk_offset(blockid)%nlvls - do i=1,btofc_blk_offset(blockid)%ncols - pter(i,k) = 1 + record_size* & - (btofc_blk_offset(blockid)%pter(i,k)) - enddo - do i=btofc_blk_offset(blockid)%ncols+1,fdim - pter(i,k) = -1 - enddo - enddo -! - do k=btofc_blk_offset(blockid)%nlvls+1,ldim - do i=1,fdim - pter(i,k) = -1 - enddo - enddo -! - return - end subroutine block_to_chunk_send_pters -! -!======================================================================== - - subroutine block_to_chunk_recv_pters(lcid, fdim, ldim, & - record_size, pter) -!----------------------------------------------------------------------- -! -! Purpose: Return pointers into receive buffer where data for -! decomposed chunk data structures should be copied from -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: fdim ! first dimension of pter array - integer, intent(in) :: ldim ! last dimension of pter array - integer, intent(in) :: record_size ! per coordinate amount of data - - integer, intent(out) :: pter(fdim,ldim) ! buffer offset -!---------------------------Local workspace----------------------------- - integer :: i, k ! loop indices -!----------------------------------------------------------------------- - if ((btofc_chk_offset(lcid)%ncols > fdim) .or. & - (btofc_chk_offset(lcid)%nlvls > ldim)) then - write(iulog,*) "BLOCK_TO_CHUNK_RECV_PTERS: pter array dimensions ", & - "not large enough: (",fdim,",",ldim,") not >= (", & - btofc_chk_offset(lcid)%ncols,",", & - btofc_chk_offset(lcid)%nlvls,")" - call endrun() - endif -! - do k=1,btofc_chk_offset(lcid)%nlvls - do i=1,btofc_chk_offset(lcid)%ncols - pter(i,k) = 1 + record_size* & - (btofc_chk_offset(lcid)%pter(i,k)) - enddo - do i=btofc_chk_offset(lcid)%ncols+1,fdim - pter(i,k) = -1 - enddo - enddo -! - do k=btofc_chk_offset(lcid)%nlvls+1,ldim - do i=1,fdim - pter(i,k) = -1 - enddo - enddo -! - return - end subroutine block_to_chunk_recv_pters -! -!======================================================================== - - subroutine transpose_chunk_to_block(record_size, chunk_buffer, & - block_buffer, window) -!----------------------------------------------------------------------- -! -! Purpose: Transpose buffer containing decomposed -! chunk data structures to buffer -! containing decomposed fields -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -#if ( defined SPMD ) -# if defined(MODCM_DP_TRANSPOSE) - use mod_comm, only: blockdescriptor, mp_sendirr, mp_recvirr, & - get_partneroffset, max_nparcels - use mpishorthand, only : mpicom -# endif - use spmd_utils, only: altalltoallv -#endif -!------------------------------Parameters------------------------------- -! - integer, parameter :: msgtag = 7000 -!------------------------------Arguments-------------------------------- - integer, intent(in) :: record_size ! per column amount of data - real(r8), intent(in):: chunk_buffer(record_size*chunk_buf_nrecs) - ! buffer of chunk data to be - ! transposed - real(r8), intent(out) :: block_buffer(record_size*block_buf_nrecs) - ! buffer of block data to - ! transpose into - integer, intent(in), optional :: window - ! MPI-2 window id for - ! chunk_buffer - -!---------------------------Local workspace----------------------------- -#if ( defined SPMD ) - integer :: p ! loop indices - integer :: bbuf_siz ! size of block_buffer - integer :: cbuf_siz ! size of chunk_buffer - integer :: lwindow ! placeholder for missing window - integer :: lopt ! local copy of phys_alltoall -! - logical, save :: first = .true. - integer, allocatable, save :: sndcnts(:), sdispls(:) - integer, allocatable, save :: rcvcnts(:), rdispls(:) - integer, allocatable, save :: pdispls(:) - integer, save :: prev_record_size = 0 -# if defined(MODCM_DP_TRANSPOSE) - type (blockdescriptor), allocatable, save :: sendbl(:), recvbl(:) - integer ione, ierror, mod_method -# endif -!----------------------------------------------------------------------- - if (first) then -! Compute send/recv/put counts and displacements - allocate(sndcnts(0:npes-1)) - allocate(sdispls(0:npes-1)) - allocate(rcvcnts(0:npes-1)) - allocate(rdispls(0:npes-1)) - allocate(pdispls(0:npes-1)) -! -# if defined(MODCM_DP_TRANSPOSE) -! This branch uses mod_comm. Admissable values of phys_alltoall are -! 11,12 and 13. Each value corresponds to a differerent option -! within mod_comm of implementing the communication. That option is expressed -! internally to mod_comm using the variable mod_method defined below; -! mod_method will have values 0,1 or 2 and is defined as -! phys_alltoall - modmin_alltoall, where modmin_alltoall equals 11. -! Also, sendbl and recvbl must have exactly npes elements, to match -! this size of the communicator, or the transpose will fail. -! - if (phys_alltoall >= modmin_alltoall) then - mod_method = phys_alltoall - modmin_alltoall - ione = 1 - allocate( sendbl(0:npes-1) ) - allocate( recvbl(0:npes-1) ) - - do p = 0,npes-1 - - sendbl(p)%method = mod_method - recvbl(p)%method = mod_method - - allocate( sendbl(p)%blocksizes(1) ) - allocate( sendbl(p)%displacements(1) ) - allocate( recvbl(p)%blocksizes(1) ) - allocate( recvbl(p)%displacements(1) ) - - enddo - - endif -# endif -! - first = .false. - endif -! - if (record_size /= prev_record_size) then -! -! Compute send/recv/put counts and displacements - sdispls(0) = 0 - sndcnts(0) = record_size*btofc_chk_num(0) - do p=1,npes-1 - sdispls(p) = sdispls(p-1) + sndcnts(p-1) - sndcnts(p) = record_size*btofc_chk_num(p) - enddo -! - rdispls(0) = 0 - rcvcnts(0) = record_size*btofc_blk_num(0) - do p=1,npes-1 - rdispls(p) = rdispls(p-1) + rcvcnts(p-1) - rcvcnts(p) = record_size*btofc_blk_num(p) - enddo -! - call mpialltoallint(rdispls, 1, pdispls, 1, mpicom) -! -# if defined(MODCM_DP_TRANSPOSE) - if (phys_alltoall >= modmin_alltoall) then - do p = 0,npes-1 - - sendbl(p)%type = MPI_DATATYPE_NULL - if ( sndcnts(p) /= 0 ) then - - if (phys_alltoall > modmin_alltoall) then - call MPI_TYPE_INDEXED(ione, sndcnts(p), & - sdispls(p), mpir8, & - sendbl(p)%type, ierror) - call MPI_TYPE_COMMIT(sendbl(p)%type, ierror) - endif - - sendbl(p)%blocksizes(1) = sndcnts(p) - sendbl(p)%displacements(1) = sdispls(p) - sendbl(p)%partneroffset = 0 - - else - - sendbl(p)%blocksizes(1) = 0 - sendbl(p)%displacements(1) = 0 - sendbl(p)%partneroffset = 0 - - endif - sendbl(p)%nparcels = size(sendbl(p)%displacements) - sendbl(p)%tot_size = sum(sendbl(p)%blocksizes) - max_nparcels = max(max_nparcels, sendbl(p)%nparcels) - - recvbl(p)%type = MPI_DATATYPE_NULL - if ( rcvcnts(p) /= 0) then - - if (phys_alltoall > modmin_alltoall) then - call MPI_TYPE_INDEXED(ione, rcvcnts(p), & - rdispls(p), mpir8, & - recvbl(p)%type, ierror) - call MPI_TYPE_COMMIT(recvbl(p)%type, ierror) - endif - - recvbl(p)%blocksizes(1) = rcvcnts(p) - recvbl(p)%displacements(1) = rdispls(p) - recvbl(p)%partneroffset = 0 ! not properly initialized - do not use Mpi2 - else - - recvbl(p)%blocksizes(1) = 0 - recvbl(p)%displacements(1) = 0 - recvbl(p)%partneroffset = 0 + off_size = SIZE(phys_columns(index)%dyn_block_index, 1) + if (SIZE(blk_ind, 1) < off_size) then + call endrun(subname//'blk_ind too small') + end if + blk_num = phys_columns(index)%local_dyn_block + blk_ind(1:off_size) = phys_columns(index)%dyn_block_index(1:off_size) + if (SIZE(blk_ind, 1) > off_size) then + blk_ind(off_size+1:) = -1 + end if + end if - endif - recvbl(p)%nparcels = size(recvbl(p)%displacements) - recvbl(p)%tot_size = sum(recvbl(p)%blocksizes) - max_nparcels = max(max_nparcels, recvbl(p)%nparcels) + end subroutine get_dyn_col_p_index - enddo + !======================================================================== - call get_partneroffset(mpicom, sendbl, recvbl) + subroutine get_gcol_all_p(lcid, gdim, gcols) + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc + ! collect global column indices of all physics columns in a chunk + + ! Dummy arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: gdim ! gcols dimension + integer, intent(out) :: gcols(:) ! global column indices + ! Local variables + integer :: ncol, col_ind + character(len=128) :: errmsg + character(len=*), parameter :: subname = 'get_gcol_all_p: ' - endif -# endif -! - prev_record_size = record_size - endif -! - call t_barrierf('sync_tran_ctob', mpicom) - if (phys_alltoall < 0) then - if ((max_nproc_smpx > npes/2) .and. (nproc_busy_d > npes/2)) then - lopt = 0 - else - lopt = 1 - endif - else - lopt = phys_alltoall - if ((lopt == 2) .and. ( .not. present(window) )) lopt = 1 - endif - if (lopt < 4) then -! - bbuf_siz = record_size*block_buf_nrecs - cbuf_siz = record_size*chunk_buf_nrecs - if ( present(window) ) then - call altalltoallv(lopt, iam, npes, & - dp_coup_steps, dp_coup_proc, & - chunk_buffer, cbuf_siz, sndcnts, sdispls, mpir8, & - block_buffer, bbuf_siz, rcvcnts, rdispls, mpir8, & - msgtag, pdispls, mpir8, window, mpicom) + if (.not. phys_grid_initialized()) then + call endrun(subname//'physics grid not initialized') + else if ((lcid < begchunk) .or. (lcid > endchunk)) then + write(errmsg, '(a,3(a,i0))') subname, 'lcid (', lcid, & + ') out of range (', begchunk, ' to ', endchunk + write(iulog, *) trim(errmsg) + call endrun(trim(errmsg)) else - call altalltoallv(lopt, iam, npes, & - dp_coup_steps, dp_coup_proc, & - chunk_buffer, cbuf_siz, sndcnts, sdispls, mpir8, & - block_buffer, bbuf_siz, rcvcnts, rdispls, mpir8, & - msgtag, pdispls, mpir8, lwindow, mpicom) - endif -! - else -# if defined(MODCM_DP_TRANSPOSE) - call mp_sendirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) - call mp_recvirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) -# else - call mpialltoallv(chunk_buffer, sndcnts, sdispls, mpir8, & - block_buffer, rcvcnts, rdispls, mpir8, & - mpicom) -# endif -! - endif -! -#endif - - return - end subroutine transpose_chunk_to_block -! -!======================================================================== - - subroutine chunk_to_block_send_pters(lcid, fdim, ldim, & - record_size, pter) -!----------------------------------------------------------------------- -! -! Purpose: Return pointers into send buffer where data for -! decomposed chunk data structures should be copied to -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: fdim ! first dimension of pter array - integer, intent(in) :: ldim ! last dimension of pter array - integer, intent(in) :: record_size ! per coordinate amount of data - - integer, intent(out) :: pter(fdim,ldim) ! buffer offset -!---------------------------Local workspace----------------------------- - integer :: i, k ! loop indices -!----------------------------------------------------------------------- - if ((btofc_chk_offset(lcid)%ncols > fdim) .or. & - (btofc_chk_offset(lcid)%nlvls > ldim)) then - write(iulog,*) "CHUNK_TO_BLOCK_SEND_PTERS: pter array dimensions ", & - "not large enough: (",fdim,",",ldim,") not >= (", & - btofc_chk_offset(lcid)%ncols,",", & - btofc_chk_offset(lcid)%nlvls,")" - call endrun() - endif -! - do k=1,btofc_chk_offset(lcid)%nlvls - do i=1,btofc_chk_offset(lcid)%ncols - pter(i,k) = 1 + record_size* & - (btofc_chk_offset(lcid)%pter(i,k)) - enddo - do i=btofc_chk_offset(lcid)%ncols+1,fdim - pter(i,k) = -1 - enddo - enddo -! - do k=btofc_chk_offset(lcid)%nlvls+1,ldim - do i=1,fdim - pter(i,k) = -1 - enddo - enddo -! - return - end subroutine chunk_to_block_send_pters -! -!======================================================================== - - subroutine chunk_to_block_recv_pters(blockid, fdim, ldim, & - record_size, pter) -!----------------------------------------------------------------------- -! -! Purpose: Return pointers into receive buffer where column from decomposed -! fields should be copied from -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- -!------------------------------Arguments-------------------------------- - integer, intent(in) :: blockid ! block index - integer, intent(in) :: fdim ! first dimension of pter array - integer, intent(in) :: ldim ! last dimension of pter array - integer, intent(in) :: record_size ! per coordinate amount of data - - integer, intent(out) :: pter(fdim,ldim) ! buffer offsets -!---------------------------Local workspace----------------------------- - integer :: i, k ! loop indices -!----------------------------------------------------------------------- - if ((btofc_blk_offset(blockid)%ncols > fdim) .or. & - (btofc_blk_offset(blockid)%nlvls > ldim)) then - write(iulog,*) "CHUNK_TO_BLOCK_RECV_PTERS: pter array dimensions ", & - "not large enough: (",fdim,",",ldim,") not >= (", & - btofc_blk_offset(blockid)%ncols,",", & - btofc_blk_offset(blockid)%nlvls,")" - call endrun() - endif -! - do k=1,btofc_blk_offset(blockid)%nlvls - do i=1,btofc_blk_offset(blockid)%ncols - pter(i,k) = 1 + record_size* & - (btofc_blk_offset(blockid)%pter(i,k)) - enddo - do i=btofc_blk_offset(blockid)%ncols+1,fdim - pter(i,k) = -1 - enddo - enddo -! - do k=btofc_blk_offset(blockid)%nlvls+1,ldim - do i=1,fdim - pter(i,k) = -1 - enddo - enddo -! - return - end subroutine chunk_to_block_recv_pters -! -!======================================================================== - - subroutine create_chunks(opt, chunks_per_thread) -!----------------------------------------------------------------------- -! -! Purpose: Decompose physics computational grid into chunks, for -! improved serial efficiency and parallel load balance. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use pmgrid, only: plev - use dyn_grid, only: get_block_bounds_d, get_block_gcol_cnt_d, & - get_gcol_block_cnt_d, get_gcol_block_d, & - get_block_owner_d, get_block_gcol_d -!------------------------------Arguments-------------------------------- - integer, intent(in) :: opt ! chunking option - ! 0: chunks may cross block boundaries, but retain same - ! process mapping as blocks. If possible, columns assigned - ! as day/night pairs. Columns (or pairs) are wrap-mapped. - ! May not work with vertically decomposed blocks. (default) - ! 1: chunks may cross block boundaries, but retain same - ! SMP-node mapping as blocks. If possible, columns assigned - ! as day/night pairs. Columns (or pairs) are wrap-mapped. - ! May not work with vertically decomposed blocks. - ! 2: 2-column day/night and season column pairs wrap-mapped - ! to chunks to also balance assignment of polar, mid-latitude, - ! and equatorial columns across chunks. - ! 3: same as 1 except that SMP defined to be pairs of consecutive - ! processes - ! 4: chunks may cross block boundaries, but retain same - ! process mapping as blocks. Columns assigned to chunks - ! in block ordering. - ! May not work with vertically decomposed blocks. - ! 5: Chunks do not cross latitude boundaries, and are block-mapped. - integer, intent(in) :: chunks_per_thread - ! target number of chunks per - ! thread -!---------------------------Local workspace----------------------------- - integer :: i, j, p ! loop indices - integer :: nlthreads ! number of local OpenMP threads - integer :: npthreads(0:npes-1) ! number of OpenMP threads per process - integer :: proc_smp_mapx(0:npes-1) ! process/virtual SMP node map - integer :: firstblock, lastblock ! global block index bounds - integer :: maxblksiz ! maximum number of columns in a dynamics block - integer :: block_cnt ! number of blocks containing data - ! for a given vertical column - integer :: blockids(plev+1) ! block indices - integer :: bcids(plev+1) ! block column indices - integer :: nsmpx, nsmpy ! virtual SMP node counts and indices - integer :: curgcol, twingcol ! global physics and dynamics column indices - integer :: smp ! SMP node index - integer :: cid ! chunk id - integer :: jb, ib ! global block and columns indices - integer :: blksiz ! current block size - integer :: ntmp1, ntmp2, nlchunks ! work variables - integer :: max_ncols ! upper bound on number of columns in a block - integer :: ncols ! number of columns in current chunk - logical :: error ! error flag - - ! indices for dynamics columns in given block - integer, dimension(:), allocatable :: cols - - ! number of MPI processes per virtual SMP node (0:nsmpx-1) - integer, dimension(:), allocatable :: nsmpprocs - - ! flag indicating whether a process is busy or idle during the dynamics (0:npes-1) - logical, dimension(:), allocatable :: proc_busy_d - - ! flag indicating whether any of the processes assigned to an SMP node are busy - ! during the dynamics, or whether all of them are idle (0:nsmps-1) - logical, dimension(:), allocatable :: smp_busy_d - - ! actual SMP node/virtual SMP node map (0:nsmps-1) - integer, dimension(:), allocatable :: smp_smp_mapx - - ! column/virtual SMP node map (ngcols) - integer, dimension(:), allocatable :: col_smp_mapx - - ! number of columns assigned to a given virtual SMP node (0:nsmpx-1) - integer, dimension(:), allocatable :: nsmpcolumns - - ! number of OpenMP threads per virtual SMP node (0:nsmpx-1) - integer, dimension(:), allocatable :: nsmpthreads - - ! number of chunks assigned to a given virtual SMP node (0:nsmpx-1) - integer, dimension(:), allocatable :: nsmpchunks - - ! maximum number of columns assigned to a chunk in a given virtual SMP node (0:nsmpx-1) - integer, dimension(:), allocatable :: maxcol_chk - - ! number of chunks in given virtual SMP node receiving maximum number of columns - ! (0:nsmpx-1) - integer, dimension(:), allocatable :: maxcol_chks - - ! chunk id virtual offset (0:nsmpx-1) - integer, dimension(:), allocatable :: cid_offset - - ! process-local chunk id (0:nsmpx-1) - integer, dimension(:), allocatable :: local_cid - -#if ( defined _OPENMP ) - integer omp_get_max_threads - external omp_get_max_threads -#endif - -!----------------------------------------------------------------------- -! -! Determine number of threads per process -! - nlthreads = 1 -#if ( defined _OPENMP ) - nlthreads = OMP_GET_MAX_THREADS() -#endif -! -#if ( defined SPMD ) - call mpiallgatherint(nlthreads, 1, npthreads, 1, mpicom) -#else - npthreads(0) = nlthreads - proc_smp_map(0) = 0 -#endif - -! -! Determine index range for dynamics blocks -! - call get_block_bounds_d(firstblock,lastblock) - -! -! Determine maximum number of columns in a block -! - maxblksiz = 0 - do jb=firstblock,lastblock - maxblksiz = max(maxblksiz,get_block_gcol_cnt_d(jb)) - enddo - -! -! determine which (and how many) processes are assigned -! dynamics blocks -! - allocate( proc_busy_d(0:npes-1) ) - proc_busy_d = .false. - nproc_busy_d = 0 - do jb=firstblock,lastblock - p = get_block_owner_d(jb) - if (.not. proc_busy_d(p) ) then - proc_busy_d(p) = .true. - nproc_busy_d = nproc_busy_d + 1 - endif - enddo - -! -! Determine virtual SMP count and processes/virtual SMP map. -! If option 0 or >3, pretend that each SMP has only one process. -! If option 1, use SMP information. -! If option 2, pretend that all processes are in one SMP node. -! If option 3, pretend that each SMP node is made up of two -! processes, chosen to maximize load-balancing opportunities. -! -! For all options < 5, if there are "idle" dynamics processes, -! assign them to the virtual SMP nodes in wrap fashion. -! Communication between the active and idle dynamics -! processes is scatter/gather (no communications between -! idle dynamics processes) so there is no advantage to -! blocking the idle processes in these assignments. -! - if ((opt <= 0) .or. (opt == 4)) then - -! assign active dynamics processes to virtual SMP nodes - nsmpx = 0 - do p=0,npes-1 - if (proc_busy_d(p)) then - proc_smp_mapx(p) = nsmpx - nsmpx = nsmpx + 1 - endif - enddo -! -! assign idle dynamics processes to virtual SMP nodes (wrap map) - nsmpy = 0 - do p=0,npes-1 - if (.not. proc_busy_d(p)) then - proc_smp_mapx(p) = nsmpy - nsmpy = mod(nsmpy+1,nsmpx) - endif - enddo - - elseif (opt == 1) then + ncol = chunks(lcid)%ncols + if (gdim < ncol) then + if (masterproc) then + write(iulog, '(2a,2(i0,a))') subname, 'WARNING: gdim (', gdim, & + ') < ncol (', ncol,'), not all indices will be filled.' + end if + gcols(gdim+1:ncol) = -1 + end if + do col_ind = 1, MIN(ncol, gdim) + gcols(col_ind) = get_gcol_p(lcid, col_ind) + end do + end if - allocate( smp_busy_d(0:nsmps-1) ) - allocate( smp_smp_mapx(0:nsmps-1) ) + end subroutine get_gcol_all_p -! -! determine SMP nodes assigned dynamics blocks - smp_busy_d = .false. - do p=0,npes-1 - if ( proc_busy_d(p) ) then - smp = proc_smp_map(p) - smp_busy_d(smp) = .true. - endif - enddo + !======================================================================== -! -! determine number of SMP nodes assigned dynamics blocks - nsmpx = 0 - do smp=0,nsmps-1 - if (smp_busy_d(smp)) then - smp_smp_mapx(smp) = nsmpx - nsmpx = nsmpx + 1 - endif - enddo -! -! assign processes in active dynamics SMP nodes to virtual SMP nodes - do p=0,npes-1 - smp = proc_smp_map(p) - if (smp_busy_d(smp)) then - proc_smp_mapx(p) = smp_smp_mapx(smp) - endif - enddo -! -! assign processes in idle dynamics SMP nodes to virtual SMP nodes (wrap map) - nsmpy = 0 - do p=0,npes-1 - smp = proc_smp_map(p) - if (.not. smp_busy_d(smp)) then - proc_smp_mapx(p) = nsmpy - nsmpy = mod(nsmpy+1,nsmpx) - endif - enddo -! - deallocate( smp_busy_d ) - deallocate( smp_smp_mapx ) + subroutine get_chunk_info_p(index, lchnk, icol) + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + ! local chunk index and column number of a physics column - elseif (opt == 2) then + ! Dummy arguments + integer, intent(in) :: index + integer, intent(out) :: lchnk + integer, intent(out) :: icol + ! Local variables + character(len=128) :: errmsg + character(len=*), parameter :: subname = 'get_chunk_info_p: ' - nsmpx = 1 - do p=0,npes-1 - proc_smp_mapx(p) = 0 - enddo + if (.not. phys_grid_initialized()) then + call endrun(subname//': physics grid not initialized') + else if ((index < 1) .or. (index > columns_on_task)) then + write(errmsg, '(a,2(a,i0))') subname, 'index (', index, & + ') out of range (1 to ', columns_on_task + write(iulog, *) errmsg + call endrun(errmsg) + else + lchnk = phys_columns(index)%local_phys_chunk + icol = phys_columns(index)%phys_chunk_index + end if - elseif (opt == 3) then + end subroutine get_chunk_info_p -! find active process partners - proc_smp_mapx = -1 - call find_partners(opt,proc_busy_d,nsmpx,proc_smp_mapx) -! -! assign unassigned (idle dynamics) processes to virtual SMP nodes -! (wrap map) - nsmpy = 0 - do p=0,npes-1 - if (proc_smp_mapx(p) == -1) then - proc_smp_mapx(p) = nsmpy - nsmpy = mod(nsmpy+1,nsmpx) - endif - enddo - - else - - nsmpx = npes - do p=0,npes-1 - proc_smp_mapx(p) = p - enddo - - endif -! - deallocate( proc_busy_d ) + !======================================================================== -! -! Determine maximum number of processes assigned to a single -! virtual SMP node -! - allocate( nsmpprocs(0:nsmpx-1) ) -! - nsmpprocs(:) = 0 - do p=0,npes-1 - smp = proc_smp_mapx(p) - nsmpprocs(smp) = nsmpprocs(smp) + 1 - enddo - max_nproc_smpx = maxval(nsmpprocs) -! - deallocate( nsmpprocs ) + subroutine get_grid_dims(hdim1_d_out, hdim2_d_out) + use cam_abortutils, only: endrun + ! retrieve dynamics field grid information + ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then hdim2_d == 1. + integer, intent(out) :: hdim1_d_out + integer, intent(out) :: hdim2_d_out -! -! Determine number of columns assigned to each -! virtual SMP in block decomposition + if (.not. phys_grid_initialized()) then + call endrun('get_grid_dims: physics grid not initialized') + end if + hdim1_d_out = hdim1_d + hdim2_d_out = hdim2_d - allocate( col_smp_mapx(ngcols) ) -! - col_smp_mapx(:) = -1 - error = .false. - do i=1,num_global_phys_cols - curgcol = latlon_to_dyn_gcol_map(i) - block_cnt = get_gcol_block_cnt_d(curgcol) - call get_gcol_block_d(curgcol,block_cnt,blockids,bcids) - do jb=1,block_cnt - p = get_block_owner_d(blockids(jb)) - if (col_smp_mapx(i) == -1) then - col_smp_mapx(i) = proc_smp_mapx(p) - elseif (col_smp_mapx(i) /= proc_smp_mapx(p)) then - error = .true. - endif - enddo - end do - if (error) then - write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & - "but vertical decomposition not limited to virtual SMP" - call endrun() - endif -! - allocate( nsmpcolumns(0:nsmpx-1) ) - nsmpcolumns(:) = 0 - do i=1,num_global_phys_cols - curgcol = latlon_to_dyn_gcol_map(i) - smp = col_smp_mapx(curgcol) - nsmpcolumns(smp) = nsmpcolumns(smp) + 1 - end do -! - deallocate( col_smp_mapx ) + end subroutine get_grid_dims -! -! Allocate other work space -! - allocate( nsmpthreads(0:nsmpx-1) ) - allocate( nsmpchunks (0:nsmpx-1) ) - allocate( maxcol_chk (0:nsmpx-1) ) - allocate( maxcol_chks(0:nsmpx-1) ) - allocate( cid_offset (0:nsmpx-1) ) - allocate( local_cid (0:nsmpx-1) ) - allocate( cols(1:maxblksiz) ) -! -! Options 0-3: split local dynamics blocks into chunks, -! using wrap-map assignment of columns and -! day/night and north/south column pairs -! to chunks to improve load balance -! Option 0: local is per process -! Option 1: local is subset of`processes assigned to same SMP node -! Option 2: local is global -! Option 3: local is pair of processes chosen to maximize load-balance -! wrt restriction that only communicate with one other -! process. -! Option 4: split local dynamics blocks into chunks, -! using block-map assignment of columns -! - if ((opt >= 0) .and. (opt <= 4)) then -! -! Calculate number of threads available in each SMP node. -! - nsmpthreads(:) = 0 - do p=0,npes-1 - smp = proc_smp_mapx(p) - nsmpthreads(smp) = nsmpthreads(smp) + npthreads(p) - enddo -! -! Determine number of chunks to keep all threads busy -! - nchunks = 0 - do smp=0,nsmpx-1 - nsmpchunks(smp) = nsmpcolumns(smp)/pcols - if (mod(nsmpcolumns(smp), pcols) /= 0) then - nsmpchunks(smp) = nsmpchunks(smp) + 1 - endif - if (nsmpchunks(smp) < chunks_per_thread*nsmpthreads(smp)) then - nsmpchunks(smp) = chunks_per_thread*nsmpthreads(smp) - endif - do while (mod(nsmpchunks(smp), nsmpthreads(smp)) /= 0) - nsmpchunks(smp) = nsmpchunks(smp) + 1 - enddo - if (nsmpchunks(smp) > nsmpcolumns(smp)) then - nsmpchunks(smp) = nsmpcolumns(smp) - endif - nchunks = nchunks + nsmpchunks(smp) - enddo -! -! Determine maximum number of columns to assign to chunks -! in a given SMP -! - do smp=0,nsmpx-1 - if (nsmpchunks(smp) /= 0) then - ntmp1 = nsmpcolumns(smp)/nsmpchunks(smp) - ntmp2 = mod(nsmpcolumns(smp),nsmpchunks(smp)) - if (ntmp2 > 0) then - maxcol_chk(smp) = ntmp1 + 1 - maxcol_chks(smp) = ntmp2 - else - maxcol_chk(smp) = ntmp1 - maxcol_chks(smp) = nsmpchunks(smp) - endif + !======================================================================== + + ! Note: This routine is a stub for future load-balancing + subroutine phys_decomp_to_dyn() + !----------------------------------------------------------------------- + ! + ! phys_decomp_to_dyn: Transfer physics data to dynamics decomp + ! + !----------------------------------------------------------------------- + end subroutine phys_decomp_to_dyn + + !======================================================================== + + ! Note: This routine is a stub for future load-balancing + subroutine dyn_decomp_to_phys() + !----------------------------------------------------------------------- + ! + ! dyn_decomp_to_phys: Transfer dynamics data to physics decomp + ! + !----------------------------------------------------------------------- + + end subroutine dyn_decomp_to_phys + + !======================================================================== + + subroutine dump_grid_map(grid_map) + use spmd_utils, only: iam, npes, mpicom + use cam_grid_support, only: iMap + + integer(iMap), pointer :: grid_map(:,:) + + integer :: num_cols + integer :: penum, icol + logical :: unstruct + integer :: file + integer :: ierr + + unstruct = SIZE(grid_map, 1) == 3 + num_cols = SIZE(grid_map, 2) + if (iam == 0) then + open(newunit=file, file='physgrid_map.csv', status='replace') + if (unstruct) then + write(file, *) '"iam","col","block","map pos"' else - maxcol_chk(smp) = 0 - maxcol_chks(smp) = 0 - endif - enddo -! -! Allocate chunks and knuhcs data structures -! - allocate( chunks(1:nchunks) ) - allocate( knuhcs(1:ngcols) ) -! -! Initialize chunks and knuhcs data structures -! - chunks(:)%ncols = 0 - knuhcs(:)%chunkid = -1 - knuhcs(:)%col = -1 -! -! Determine chunk id ranges for each SMP -! - cid_offset(0) = 1 - local_cid(0) = 0 - do smp=1,nsmpx-1 - cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) - local_cid(smp) = 0 - enddo -! -! Assign columns to chunks -! - do jb=firstblock,lastblock - p = get_block_owner_d(jb) - smp = proc_smp_mapx(p) - blksiz = get_block_gcol_cnt_d(jb) - call get_block_gcol_d(jb,blksiz,cols) - do ib = 1,blksiz -! -! Assign column to a chunk if not already assigned - curgcol = cols(ib) - if ((dyn_to_latlon_gcol_map(curgcol) /= -1) .and. & - (knuhcs(curgcol)%chunkid == -1)) then -! -! Find next chunk with space -! (maxcol_chks > 0 test necessary for opt=4 block map) - cid = cid_offset(smp) + local_cid(smp) - if (maxcol_chks(smp) > 0) then - do while (chunks(cid)%ncols >= maxcol_chk(smp)) - local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) - cid = cid_offset(smp) + local_cid(smp) - enddo + write(file, *) '"iam","col","block","lon","lat"' + end if + close(unit=file) + end if + do penum = 0, npes - 1 + if (iam == penum) then + open(newunit=file, file='physgrid_map.csv', status='old', & + action='readwrite', position='append') + do icol = 1, num_cols + if (unstruct) then + write(file, '(3(i0,","),i0)') iam, int(grid_map(1,icol)), & + int(grid_map(2,icol)), int(grid_map(3,icol)) else - do while (chunks(cid)%ncols >= maxcol_chk(smp)-1) - local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) - cid = cid_offset(smp) + local_cid(smp) - enddo - endif - chunks(cid)%ncols = chunks(cid)%ncols + 1 - if (chunks(cid)%ncols == maxcol_chk(smp)) & - maxcol_chks(smp) = maxcol_chks(smp) - 1 -! - i = chunks(cid)%ncols - chunks(cid)%gcol(i) = curgcol - chunks(cid)%lon(i) = lon_p(curgcol) - chunks(cid)%lat(i) = lat_p(curgcol) - knuhcs(curgcol)%chunkid = cid - knuhcs(curgcol)%col = i -! - if (opt < 4) then -! -! If space available, look to assign a load-balancing "twin" to same chunk - if ( (chunks(cid)%ncols < maxcol_chk(smp)) .and. & - (maxcol_chks(smp) > 0) .and. (twin_alg > 0)) then - - call find_twin(curgcol, smp, & - proc_smp_mapx, twingcol) - - if (twingcol > 0) then - chunks(cid)%ncols = chunks(cid)%ncols + 1 - if (chunks(cid)%ncols == maxcol_chk(smp)) & - maxcol_chks(smp) = maxcol_chks(smp) - 1 -! - i = chunks(cid)%ncols - chunks(cid)%gcol(i) = twingcol - chunks(cid)%lon(i) = lon_p(twingcol) - chunks(cid)%lat(i) = lat_p(twingcol) - knuhcs(twingcol)%chunkid = cid - knuhcs(twingcol)%col = i - endif -! - endif -! -! Move on to next chunk (wrap map) - local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) -! - endif -! - endif - enddo - enddo -! - else -! -! Option 5: split individual dynamics blocks into chunks, -! assigning consecutive columns to the same chunk -! -! Determine total number of chunks and -! number of chunks in each "SMP node" -! (assuming no vertical decomposition) - nchunks = 0 - nsmpchunks(:) = 0 - do j=firstblock,lastblock - blksiz = get_block_gcol_cnt_d(j) - nlchunks = blksiz/pcols - if (pcols*(blksiz/pcols) /= blksiz) then - nlchunks = nlchunks + 1 - endif - nchunks = nchunks + nlchunks - p = get_block_owner_d(j) - nsmpchunks(p) = nsmpchunks(p) + nlchunks - enddo -! -! Determine chunk id ranges for each SMP -! - cid_offset(0) = 1 - local_cid(0) = 0 - do smp=1,nsmpx-1 - cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) - local_cid(smp) = 0 - enddo -! -! Allocate chunks and knuhcs data structures -! - allocate( chunks(1:nchunks) ) - allocate( knuhcs(1:ngcols) ) -! -! Initialize chunks and knuhcs data structures -! - knuhcs(:)%chunkid = -1 - knuhcs(:)%col = -1 - cid = 0 - do jb=firstblock,lastblock - p = get_block_owner_d(jb) - smp = proc_smp_mapx(p) - blksiz = get_block_gcol_cnt_d(jb) - call get_block_gcol_d(jb,blksiz,cols) - - ib = 0 - do while (ib < blksiz) - - cid = cid_offset(smp) + local_cid(smp) - max_ncols = min(pcols,blksiz-ib) - - ncols = 0 - do i=1,max_ncols - ib = ib + 1 - ! check whether global index is for a column that dynamics - ! intends to pass to the physics - curgcol = cols(ib) - if (dyn_to_latlon_gcol_map(curgcol) /= -1) then - ! yes - then save the information - ncols = ncols + 1 - chunks(cid)%gcol(ncols) = curgcol - chunks(cid)%lon(ncols) = lon_p(curgcol) - chunks(cid)%lat(ncols) = lat_p(curgcol) - knuhcs(curgcol)%chunkid = cid - knuhcs(curgcol)%col = ncols - endif - enddo - chunks(cid)%ncols = ncols + write(file, '(4(i0,","),i0)') iam, int(grid_map(1,icol)), & + int(grid_map(2,icol)), int(grid_map(3,icol)), & + int(grid_map(4,icol)) + end if + end do + close(unit=file) + end if + call MPI_barrier(mpicom, ierr) + end do + end subroutine dump_grid_map - local_cid(smp) = local_cid(smp) + 1 - enddo - enddo -! -! Set number of threads available in each "SMP node". -! - do p=0,npes-1 - nsmpthreads(p) = npthreads(p) - enddo -! - endif -! -! Assign chunks to processes. -! - call assign_chunks(npthreads, nsmpx, proc_smp_mapx, & - nsmpthreads, nsmpchunks) -! -! Clean up -! - deallocate( nsmpcolumns ) - deallocate( nsmpthreads ) - deallocate( nsmpchunks ) - deallocate( maxcol_chk ) - deallocate( maxcol_chks ) - deallocate( cid_offset ) - deallocate( local_cid ) - deallocate( cols ) - deallocate( knuhcs ) - - return - end subroutine create_chunks -! -!======================================================================== +!============================================================================= +!== +!!!!!! DUMMY INTERFACEs TO TEST WEAK SCALING INFRASTRUCTURE, SHOULD GO AWAY +!== +!============================================================================= - subroutine find_partners(opt, proc_busy_d, nsmpx, proc_smp_mapx) -!----------------------------------------------------------------------- -! -! Purpose: Divide processes into pairs, attempting to maximize the -! the number of columns in one process whose twins are in the -! other process. -! -! Method: The day/night and north/south hemisphere complement is defined -! to be the column twin. -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use dyn_grid, only: get_gcol_block_cnt_d, get_gcol_block_d, & - get_block_owner_d - use pmgrid, only: plev -!------------------------------Arguments-------------------------------- - integer, intent(in) :: opt ! chunking option - logical, intent(in) :: proc_busy_d(0:npes-1) - ! active/idle dynamics process flags - integer, intent(out) :: nsmpx ! calculated number of virtual - ! SMP nodes - integer, intent(out) :: proc_smp_mapx(0:npes-1) - ! process/virtual smp map -!---------------------------Local workspace----------------------------- - integer :: gcol_latlon ! physics column index (latlon sorted) - integer :: twingcol_latlon ! physics column index (latlon sorted) - integer :: gcol, twingcol ! physics column indices - integer :: lon, lat, twinlat ! longitude and latitude indices - integer :: twinlon_off ! estimate as to offset of twinlon - ! on a latitude line - integer :: block_cnt ! number of blocks containing data - ! for a given vertical column - integer :: blockids(plev+1) ! block indices - integer :: bcids(plev+1) ! block column indices - integer :: jb ! block index - integer :: p, twp ! process indices - integer :: col_proc_mapx(ngcols) ! location of columns in - ! dynamics decomposition - integer :: twin_proc_mapx(ngcols) ! location of column twins in - ! dynamics decomposition - integer :: twin_cnt(0:npes-1) ! for each process, number of twins - ! in each of the other processes - logical :: assigned(0:npes-1) ! flag indicating whether process - ! assigned to an SMP node yet - integer :: maxpartner, maxcnt ! process with maximum number of - ! twins and this count - - logical :: error ! error flag -!----------------------------------------------------------------------- -! -! Determine process location of column and its twin in dynamics decomposition -! - col_proc_mapx(:) = -1 - twin_proc_mapx(:) = -1 - - error = .false. - do gcol_latlon=1,num_global_phys_cols - - ! Assume latitude and longitude symmetries and that index manipulations - ! are sufficient to find partners. (Will be true for lon/lat grids.) - gcol = latlon_to_dyn_gcol_map(gcol_latlon) - lat = lat_p(gcol) - twinlat = clat_p_tot+1-lat - lon = lon_p(gcol) - twinlon_off = mod((lon-1)+(clat_p_cnt(twinlat)/2), clat_p_cnt(twinlat)) - twingcol_latlon = clat_p_idx(twinlat) + twinlon_off - twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) - - block_cnt = get_gcol_block_cnt_d(gcol) - call get_gcol_block_d(gcol,block_cnt,blockids,bcids) - do jb=1,block_cnt - p = get_block_owner_d(blockids(jb)) - if (col_proc_mapx(gcol) == -1) then - col_proc_mapx(gcol) = p - elseif (col_proc_mapx(gcol) /= p) then - error = .true. - endif - enddo - - block_cnt = get_gcol_block_cnt_d(twingcol) - call get_gcol_block_d(twingcol,block_cnt,blockids,bcids) - do jb=1,block_cnt - p = get_block_owner_d(blockids(jb)) - if (twin_proc_mapx(gcol) == -1) then - twin_proc_mapx(gcol) = p - elseif (twin_proc_mapx(gcol) /= p) then - error = .true. - endif - enddo - - end do - - if (error) then - if (masterproc) then - write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & - "but vertical decomposition not limited to single process" - endif - call endrun() - endif - -! -! Assign process pairs to SMPs, attempting to maximize the number of column,twin -! pairs in same SMP. -! - assigned(:) = .false. - twin_cnt(:) = 0 - nsmpx = 0 - do p=0,npes-1 - if ((.not. assigned(p)) .and. (proc_busy_d(p))) then -! -! For each process, determine number of twins in each of the other processes -! (running over all columns multiple times to minimize memory requirements). -! - do gcol_latlon=1,num_global_phys_cols - gcol = latlon_to_dyn_gcol_map(gcol_latlon) - if (col_proc_mapx(gcol) == p) then - twin_cnt(twin_proc_mapx(gcol)) = & - twin_cnt(twin_proc_mapx(gcol)) + 1 - endif - enddo -! -! Find process with maximum number of twins that has not yet been designated -! a partner. -! - maxpartner = -1 - maxcnt = 0 - do twp=0,npes-1 - if ((.not. assigned(twp)) .and. (twp /= p)) then - if (twin_cnt(twp) >= maxcnt) then - maxcnt = twin_cnt(twp) - maxpartner = twp - endif - endif - enddo -! -! Assign p and twp to the same SMP node -! - if (maxpartner /= -1) then - assigned(p) = .true. - assigned(maxpartner) = .true. - proc_smp_mapx(p) = nsmpx - proc_smp_mapx(maxpartner) = nsmpx - nsmpx = nsmpx + 1 - else - if (masterproc) then - write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & - "but could not divide processes into pairs." - endif - call endrun() - endif -! - endif -! - enddo -! - return - end subroutine find_partners -! -!======================================================================== + subroutine scatter_field_to_chunk(fdim,mdim,ldim, & + hdim1d,globalfield,localchunks) + use cam_abortutils, only: endrun + use ppgrid, only: pcols + !----------------------------------------------------------------------- + ! + ! Purpose: DUMMY FOR WEAK SCALING TESTS + ! + !------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + real(r8), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + real(r8), intent(out):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + + call endrun('scatter_field_to_chunk: NOT SUPPORTED WITH WEAK SCALING') + end subroutine scatter_field_to_chunk - subroutine find_twin(gcol, smp, proc_smp_mapx, twingcol_f) -!----------------------------------------------------------------------- -! -! Purpose: Find column that when paired with gcol in a chunk -! balances the load. A column is a candidate to be paired with -! gcol if it is in the same SMP node as gcol as defined -! by proc_smp_mapx. -! -! Method: The day/night and north/south hemisphere complement is -! tried first. If it is not a candidate or if it has already been -! assigned, then the day/night complement is tried next. If that -! also is not available, then nothing is returned. -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use dyn_grid, only: get_gcol_block_d, get_block_owner_d - -!------------------------------Arguments-------------------------------- - integer, intent(in) :: gcol ! global column index for column - ! seeking a twin for - integer, intent(in) :: smp ! index of SMP node - ! currently assigned to - integer, intent(in) :: proc_smp_mapx(0:npes-1) - ! process/virtual smp map - integer, intent(out) :: twingcol_f - ! global column index for twin -!---------------------------Local workspace----------------------------- - integer :: lon, lat ! global lon/lat indices for column - ! seeking a twin for - integer :: twinlon, twinlat ! lon/lat indices of twin candidate - integer :: twinlon_off ! estimate as to offset of twinlon - ! on a latitude line - logical :: found ! found flag - integer :: i ! loop index - integer :: upper, lower ! search temporaries - integer :: twingcol_latlon ! global physics column index (latlon sorted) - integer :: twingcol_lonlat ! global physics column index (lonlat sorted) - integer :: twingcol ! global physics column indes - integer :: diff, min_diff, min_i ! search temporaries - integer :: jbtwin(npes) ! global block indices - integer :: ibtwin(npes) ! global column indices - integer :: twinproc, twinsmp ! process and smp ids - - integer :: clon_p_idx(clon_p_tot) ! index in lonlat ordering for first - ! occurrence of longitude corresponding to - ! given latitude index - - real(r8):: twopi ! 2*pi - real(r8):: clat, twinclat ! latitude and twin - real(r8):: clon, twinclon ! longitude and twin - -!----------------------------------------------------------------------- - twingcol_f = -1 - - ! precompute clon_p_idx - clon_p_idx(1) = 1 - do i=2,clon_p_tot - clon_p_idx(i) = clon_p_idx(i-1) + clon_p_cnt(i-1) - enddo -! -! Try day/night and north/south hemisphere complement first -! - ! determine twin latitude - lat = lat_p(gcol) - clat = clat_p(lat) - twinclat = -clat - twinlat = clat_p_tot+1-lat - if (clat_p(twinlat) == twinclat) then - found = .true. - else - found = .false. - upper = twinlat - lower = twinlat - if (upper < clat_p_tot) upper = twinlat + 1 - if (lower > 1) lower = twinlat - 1 - endif - do while (.not. found) - if ((abs(clat_p(upper)-twinclat) < abs(clat_p(twinlat)-twinclat)) .and. & - (upper /= twinlat)) then - twinlat = upper - if (upper < clat_p_tot) then - upper = twinlat + 1 - else - found = .true. - endif - else if ((abs(clat_p(lower)-twinclat) < abs(clat_p(twinlat)-twinclat)) .and. & - (lower /= twinlat)) then - twinlat = lower - if (lower > 1) then - lower = twinlat - 1 - else - found = .true. - endif - else - found = .true. - endif - enddo - - ! determine twin longitude - twopi = 2.0_r8*pi - lon = lon_p(gcol) - clon = clon_p(lon) - twinclon = mod(clon+pi,twopi) - twinlon = mod((lon-1)+(clon_p_tot/2), clon_p_tot) + 1 - if (clon_p(twinlon) == twinclon) then - found = .true. - else - found = .false. - upper = twinlon - lower = twinlon - if (upper < clon_p_tot) upper = twinlon + 1 - if (lower > 1) lower = twinlon - 1 - endif - do while (.not. found) - if ((abs(clon_p(upper)-twinclon) < abs(clon_p(twinlon)-twinclon)) .and. & - (upper /= twinlon)) then - twinlon = upper - if (upper < clon_p_tot) then - upper = twinlon + 1 - else - found = .true. - endif - else if ((abs(clon_p(lower)-twinclon) < abs(clon_p(twinlon)-twinclon)) .and. & - (lower /= twinlon)) then - twinlon = lower - if (lower > 1) then - lower = twinlon - 1 - else - found = .true. - endif - else - found = .true. - endif - enddo - - ! first, look for an exact match (assuming latitude and longitude symmetries) - twinlon_off = mod((lon-1)+(clat_p_cnt(twinlat)/2), clat_p_cnt(twinlat)) - twingcol_latlon = clat_p_idx(twinlat) + twinlon_off - twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) - - ! otherwise, look around for an approximate match using lonlat sorted indices - if ((lon_p(twingcol) /= twinlon) .or. (lat_p(twingcol) /= twinlat)) then - twingcol_lonlat = clon_p_idx(twinlon) - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - min_diff = abs(lat_p(twingcol) - twinlat) - min_i = 0 - do i = 1, clon_p_cnt(twinlon)-1 - twingcol_lonlat = clon_p_idx(twinlon)+i - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - diff = abs(lat_p(twingcol) - twinlat) - if (diff < min_diff) then - min_diff = diff - min_i = i - endif - enddo - twingcol_lonlat = clon_p_idx(twinlon) + min_i - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - endif - - ! Check whether twin and original are in same smp - found = .false. - call get_gcol_block_d(twingcol,npes,jbtwin,ibtwin) - twinproc = get_block_owner_d(jbtwin(1)) - twinsmp = proc_smp_mapx(twinproc) -! - if ((twinsmp == smp) .and. & - (knuhcs(twingcol)%chunkid == -1)) then - found = .true. - twingcol_f = twingcol - endif -! -! Try day/night complement next - if (.not. found) then - - ! first, look for an exact match (assuming longitude symmetries) - twinlon_off = mod((lon-1)+(clat_p_cnt(lat)/2), clat_p_cnt(lat)) - twingcol_latlon = clat_p_idx(lat) + twinlon_off - twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) - - ! otherwise, look around for an approximate match using lonlat - ! column ordering - if ((lon_p(twingcol) /= twinlon) .or. & - (lat_p(twingcol) /= lat)) then - twingcol_lonlat = clon_p_idx(twinlon) - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - min_diff = abs(lat_p(twingcol) - lat) - min_i = 0 - do i = 1, clon_p_cnt(twinlon)-1 - twingcol_lonlat = clon_p_idx(twinlon)+i - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - diff = abs(lat_p(twingcol) - lat) - if (diff < min_diff) then - min_diff = diff - min_i = i - endif - enddo - twingcol_lonlat = clon_p_idx(twinlon) + min_i - twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) - endif -! - call get_gcol_block_d(twingcol,npes,jbtwin,ibtwin) - twinproc = get_block_owner_d(jbtwin(1)) - twinsmp = proc_smp_mapx(twinproc) -! - if ((twinsmp == smp) .and. & - (knuhcs(twingcol)%chunkid == -1)) then - found = .true. - twingcol_f = twingcol - endif -! - endif -! - return - end subroutine find_twin -! -!======================================================================== + !======================================================================== - subroutine assign_chunks(npthreads, nsmpx, proc_smp_mapx, & - nsmpthreads, nsmpchunks) -!----------------------------------------------------------------------- -! -! Purpose: Assign chunks to processes, balancing the number of -! chunks per thread and minimizing the communication costs -! in dp_coupling subject to the restraint that columns -! do not migrate outside of the current SMP node. -! -! Method: -! -! Author: Patrick Worley -! -!----------------------------------------------------------------------- - use pmgrid, only: plev - use dyn_grid, only: get_gcol_block_cnt_d, get_gcol_block_d,& - get_block_owner_d -!------------------------------Arguments-------------------------------- - integer, intent(in) :: npthreads(0:npes-1) - ! number of OpenMP threads per process - integer, intent(in) :: nsmpx ! virtual smp count - integer, intent(in) :: proc_smp_mapx(0:npes-1) - ! process/virtual smp map - integer, intent(in) :: nsmpthreads(0:nsmpx-1) - ! number of OpenMP threads - ! per virtual SMP - integer, intent(in) :: nsmpchunks(0:nsmpx-1) - ! number of chunks assigned - ! to a given virtual SMP -!---------------------------Local workspace----------------------------- - integer :: i, jb, p ! loop indices - integer :: cid ! chunk id - integer :: smp ! SMP index - integer :: curgcol ! global column index - integer :: block_cnt ! number of blocks containing data - ! for a given vertical column - integer :: blockids(plev+1) ! block indices - integer :: bcids(plev+1) ! block column indices - integer :: ntsks_smpx(0:nsmpx-1) ! number of processes per virtual SMP - integer :: smp_proc_mapx(0:nsmpx-1,max_nproc_smpx) - ! virtual smp to process id map - integer :: cid_offset(0:nsmpx) ! chunk id virtual smp offset - integer :: ntmp1_smp(0:nsmpx-1) ! minimum number of chunks per thread - ! in a virtual SMP - integer :: ntmp2_smp(0:nsmpx-1) ! number of extra chunks to be assigned - ! in a virtual SMP - integer :: ntmp3_smp(0:nsmpx-1) ! number of processes in a virtual - ! SMP that get more extra chunks - ! than the others - integer :: ntmp4_smp(0:nsmpx-1) ! number of extra chunks per process - ! in a virtual SMP - integer :: ntmp1, ntmp2 ! work variables -! integer :: npchunks(0:npes-1) ! number of chunks to be assigned to -! ! a given process - integer :: cur_npchunks(0:npes-1) ! current number of chunks assigned - ! to a given process - integer :: column_count(0:npes-1) ! number of columns from current chunk - ! assigned to each process in dynamics - ! decomposition -!----------------------------------------------------------------------- -! -! Count number of processes per virtual SMP and determine virtual SMP -! to process id map -! - ntsks_smpx(:) = 0 - smp_proc_mapx(:,:) = -1 - do p=0,npes-1 - smp = proc_smp_mapx(p) - ntsks_smpx(smp) = ntsks_smpx(smp) + 1 - smp_proc_mapx(smp,ntsks_smpx(smp)) = p - enddo -! -! Determine chunk id ranges for each virtual SMP -! - cid_offset(0) = 1 - do smp=1,nsmpx - cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) - enddo -! -! Determine number of chunks to assign to each process -! - do smp=0,nsmpx-1 -! -! Minimum number of chunks per thread - ntmp1_smp(smp) = nsmpchunks(smp)/nsmpthreads(smp) + subroutine get_lat_all_p_int(lcid, latdim, lats) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_lat_all_p: Return all latitudes (in degrees) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: latdim ! declared size of output array + integer, intent(out) :: lats(latdim) ! array of latitudes -! Number of extra chunks to be assigned - ntmp2_smp(smp) = mod(nsmpchunks(smp),nsmpthreads(smp)) + call endrun('get_lat_all_p: deprecated interface') -! Number of processes that get more extra chunks than the others - ntmp3_smp(smp) = mod(ntmp2_smp(smp),ntsks_smpx(smp)) + end subroutine get_lat_all_p_int -! Number of extra chunks per process - ntmp4_smp(smp) = ntmp2_smp(smp)/ntsks_smpx(smp) - if (ntmp3_smp(smp) > 0) then - ntmp4_smp(smp) = ntmp4_smp(smp) + 1 - endif - enddo + !======================================================================== - do p=0,npes-1 - smp = proc_smp_mapx(p) + subroutine get_lon_all_p_int(lcid, londim, lons) + use cam_abortutils, only: endrun + !----------------------------------------------------------------------- + ! + ! get_lon_all_p:: Return all longitudes (in degrees) for chunk, + ! + !----------------------------------------------------------------------- + ! Dummy Arguments + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: londim ! declared size of output array + integer, intent(out) :: lons(londim) ! array of longitudes -! Update number of extra chunks - if (ntmp2_smp(smp) > ntmp4_smp(smp)) then - ntmp2_smp(smp) = ntmp2_smp(smp) - ntmp4_smp(smp) - else - ntmp4_smp(smp) = ntmp2_smp(smp) - ntmp2_smp(smp) = 0 - ntmp3_smp(smp) = 0 - endif - -! Set number of chunks - npchunks(p) = ntmp1_smp(smp)*npthreads(p) + ntmp4_smp(smp) - -! Update extra chunk increment - if (ntmp3_smp(smp) > 0) then - ntmp3_smp(smp) = ntmp3_smp(smp) - 1 - if (ntmp3_smp(smp) == 0) then - ntmp4_smp(smp) = ntmp4_smp(smp) - 1 - endif - endif - enddo + call endrun('get_lon_all_p: deprecated interface') -! -! Assign chunks to processes: -! - cur_npchunks(:) = 0 -! - do smp=0,nsmpx-1 - do cid=cid_offset(smp),cid_offset(smp+1)-1 -! - do i=1,ntsks_smpx(smp) - p = smp_proc_mapx(smp,i) - column_count(p) = 0 - enddo -! -! For each chunk, determine number of columns in each -! process within the dynamics. - do i=1,chunks(cid)%ncols - curgcol = chunks(cid)%gcol(i) - block_cnt = get_gcol_block_cnt_d(curgcol) - call get_gcol_block_d(curgcol,block_cnt,blockids,bcids) - do jb=1,block_cnt - p = get_block_owner_d(blockids(jb)) - column_count(p) = column_count(p) + 1 - enddo - enddo -! -! Eliminate processes that already have their quota of chunks - do i=1,ntsks_smpx(smp) - p = smp_proc_mapx(smp,i) - if (cur_npchunks(p) == npchunks(p)) then - column_count(p) = -1 - endif - enddo -! -! Assign chunk to process with most -! columns from chunk, from among those still available - ntmp1 = -1 - ntmp2 = -1 - do i=1,ntsks_smpx(smp) - p = smp_proc_mapx(smp,i) - if (column_count(p) > ntmp1) then - ntmp1 = column_count(p) - ntmp2 = p - endif - enddo - cur_npchunks(ntmp2) = cur_npchunks(ntmp2) + 1 - chunks(cid)%owner = ntmp2 - -! Update total number of columns assigned to this process - gs_col_num(ntmp2) = gs_col_num(ntmp2) + chunks(cid)%ncols -! - enddo -! - enddo -! - return - end subroutine assign_chunks -! -!======================================================================== + end subroutine get_lon_all_p_int -!####################################################################### + !======================================================================== end module phys_grid diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 371cab1c13..7452f9e115 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -4,11 +4,8 @@ module physpkg ! ! Provides the interface to CAM physics package ! - ! Revision history: - ! Aug 2005, E. B. Kluzek, Creation of module from physpkg subroutine - ! 2005-10-17 B. Eaton Add contents of inti.F90 to phys_init(). Add - ! initialization of grid info in phys_state. - ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines + ! Module contains reordered physics to accomodate CLUBB + ! Modified after original physpkg module, Dec 2021, A. Herrington !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 @@ -21,7 +18,7 @@ module physpkg use phys_grid, only: get_ncols_p use phys_gmean, only: gmean_mass use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols - use constituents, only: pcnst, cnst_get_ind + use constituents, only: pcnst, cnst_name, cnst_get_ind use camsrfexch, only: cam_out_t, cam_in_t use cam_control_mod, only: ideal_phys, adiabatic @@ -92,7 +89,8 @@ module physpkg integer :: dvcore_idx = 0 ! dvcore index in physics buffer integer :: dtcore_idx = 0 ! dtcore index in physics buffer integer :: dqcore_idx = 0 ! dqcore index in physics buffer - + integer :: cmfmczm_idx = 0 ! Zhang-McFarlane convective mass fluxes + integer :: rliqbc_idx = 0 ! tphysbc reserve liquid !======================================================================= contains !======================================================================= @@ -110,14 +108,12 @@ subroutine phys_register use cam_abortutils, only: endrun use physics_buffer, only: pbuf_init_time, pbuf_cam_snapshot_register use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_add, cnst_chk_dim + use constituents, only: cnst_add, cnst_chk_dim use cam_control_mod, only: moist_physics use chemistry, only: chem_register use mo_lightning, only: lightning_register use cloud_fraction, only: cldfrc_register - use rk_stratiform, only: rk_stratiform_register use microp_driver, only: microp_driver_register use microp_aero, only: microp_aero_register use macrop_driver, only: macrop_driver_register @@ -127,12 +123,10 @@ subroutine phys_register use tracers, only: tracers_register use check_energy, only: check_energy_register use carma_intr, only: carma_register - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_register - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_register use ghg_data, only: ghg_data_register use vertical_diffusion, only: vd_register use convect_deep, only: convect_deep_register - use convect_shallow, only: convect_shallow_register + use convect_diagnostics,only: convect_diagnostics_register use radiation, only: radiation_register use co2_cycle, only: co2_register use flux_avg, only: flux_avg_register @@ -143,7 +137,6 @@ subroutine phys_register use prescribed_strataero,only: prescribed_strataero_register use prescribed_aero, only: prescribed_aero_register use prescribed_ghg, only: prescribed_ghg_register - use sslt_rebin, only: sslt_rebin_register use aoa_tracers, only: aoa_tracers_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register @@ -154,16 +147,13 @@ subroutine phys_register use subcol, only: subcol_register use subcol_utils, only: is_subcol_on, subcol_get_scheme use dyn_comp, only: dyn_register - use spcam_drivers, only: spcam_register use offline_driver, only: offline_driver_reg - use upper_bc, only: ubc_fixed_conc !---------------------------Local variables----------------------------- ! integer :: m ! loop index integer :: mm ! constituent index integer :: nmodes - logical :: has_fixed_ubc ! for upper bndy cond !----------------------------------------------------------------------- ! Get physics options @@ -190,12 +180,11 @@ subroutine phys_register ! Register water vapor. ! ***** N.B. ***** This must be the first call to cnst_add so that ! water vapor is constituent 1. - has_fixed_ubc = ubc_fixed_conc('Q') ! .false. if (moist_physics) then - call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, fixed_ubc=has_fixed_ubc, & + call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & longname='Specific humidity', readiv=.true., is_convtran1=.true.) else - call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, fixed_ubc=has_fixed_ubc, & + call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & longname='Specific humidity', readiv=.false., is_convtran1=.true.) end if @@ -224,24 +213,20 @@ subroutine phys_register call cldfrc_register() ! cloud water - if( microp_scheme == 'RK' ) then - call rk_stratiform_register() - elseif( microp_scheme == 'MG' ) then - if (.not. do_clubb_sgs) call macrop_driver_register() - call microp_aero_register() - call microp_driver_register() - end if + if (.not. do_clubb_sgs) call macrop_driver_register() + call microp_aero_register() + call microp_driver_register() ! Register CLUBB_SGS here if (do_clubb_sgs) call clubb_register_cam() + call pbuf_add_field('PREC_STR', 'global',dtype_r8,(/pcols/),prec_str_idx) + call pbuf_add_field('SNOW_STR', 'global',dtype_r8,(/pcols/),snow_str_idx) + call pbuf_add_field('PREC_PCW', 'global',dtype_r8,(/pcols/),prec_pcw_idx) + call pbuf_add_field('SNOW_PCW', 'global',dtype_r8,(/pcols/),snow_pcw_idx) + call pbuf_add_field('PREC_SED', 'global',dtype_r8,(/pcols/),prec_sed_idx) + call pbuf_add_field('SNOW_SED', 'global',dtype_r8,(/pcols/),snow_sed_idx) - call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) - call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) - call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) - call pbuf_add_field('SNOW_PCW', 'physpkg',dtype_r8,(/pcols/),snow_pcw_idx) - call pbuf_add_field('PREC_SED', 'physpkg',dtype_r8,(/pcols/),prec_sed_idx) - call pbuf_add_field('SNOW_SED', 'physpkg',dtype_r8,(/pcols/),snow_sed_idx) if (is_subcol_on()) then call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) @@ -251,6 +236,9 @@ subroutine phys_register call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) end if + ! Reserve liquid at end of tphysbc + call pbuf_add_field('RLIQBC','physpkg',dtype_r8,(/pcols/),rliqbc_idx) + ! Who should add FRACIS? ! -- It does not seem that aero_intr should add it since FRACIS is used in convection ! even if there are no prognostic aerosols ... so do it here for now @@ -270,27 +258,18 @@ subroutine phys_register ! register chemical constituents including aerosols ... call chem_register() - ! add prognostic lightning flash freq pbuf fld + ! add prognostic lightning flash freq pbuf fld call lightning_register() ! co2 constituents call co2_register() - ! register data model ozone with pbuf - if (cam3_ozone_data_on) then - call cam3_ozone_data_register() - end if + ! register other constituents call prescribed_volcaero_register() call prescribed_strataero_register() call prescribed_ozone_register() call prescribed_aero_register() call prescribed_ghg_register() - call sslt_rebin_register - - ! CAM3 prescribed aerosols - if (cam3_aero_data_on) then - call cam3_aero_data_register() - end if ! register various data model gasses with pbuf call ghg_data_register() @@ -312,11 +291,8 @@ subroutine phys_register ! deep convection call convect_deep_register - ! shallow convection - call convect_shallow_register - - - call spcam_register + ! convection diagnostics + call convect_diagnostics_register ! radiation call radiation_register @@ -381,10 +357,11 @@ subroutine phys_inidat( cam_out, pbuf2d ) type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) type(physics_buffer_desc), pointer :: pbuf2d(:,:) - integer :: lchnk, m, n, ncol + integer :: lchnk, m, n, i, k, ncol type(file_desc_t), pointer :: fh_ini, fh_topo character(len=8) :: fieldname real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) + real(r8), pointer :: qpert(:,:) character(len=11) :: subname='phys_inidat' ! subroutine name integer :: tpert_idx, qpert_idx, pblh_idx @@ -409,7 +386,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) end if call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - allocate(tptr(1:pcols,begchunk:endchunk)) + allocate(tptr(1:pcols,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr(1:pcols,begchunk:endchunk)') + end if if (associated(fh_topo) .and. .not. aqua_planet) then call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & @@ -418,7 +398,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) call pbuf_set_field(pbuf2d, sgh_idx, tptr) - allocate(tptr_2(1:pcols,begchunk:endchunk)) + allocate(tptr_2(1:pcols,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr_2(1:pcols,begchunk:endchunk)') + end if call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & tptr_2, found, gridname='physgrid') if(found) then @@ -473,7 +456,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' end if - allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk)) + allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d_2(pcols,pcnst,begchunk:endchunk)') + end if tptr3d_2 = 0_r8 tptr3d_2(:,1,:) = tptr(:,:) @@ -500,7 +486,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) ! 3-D fields ! - allocate(tptr3d(pcols,pver,begchunk:endchunk)) + allocate(tptr3d(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') + end if fieldname='CLOUD' m = pbuf_get_index('CLD') @@ -576,7 +565,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) end do else - allocate(tptr3d_2(pcols,pver,begchunk:endchunk)) + allocate(tptr3d_2(pcols,pver,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d_2(pcols,pver,begchunk:endchunk)') + end if call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & @@ -609,9 +601,6 @@ subroutine phys_inidat( cam_out, pbuf2d ) end if end if - deallocate(tptr3d) - allocate(tptr3d(pcols,pver,begchunk:endchunk)) - fieldname = 'TCWAT' m = pbuf_get_index(fieldname,ierr) if (m > 0) then @@ -633,8 +622,26 @@ subroutine phys_inidat( cam_out, pbuf2d ) end do end if + fieldname = 'CONCLD' + m = pbuf_get_index('CONCLD',ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + end if + deallocate(tptr3d) - allocate(tptr3d(pcols,pverp,begchunk:endchunk)) + allocate(tptr3d(pcols,pverp,begchunk:endchunk), stat=ierr) + if (ierr /= 0) then + call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') + end if fieldname = 'TKE' m = pbuf_get_index( 'tke') @@ -671,26 +678,6 @@ subroutine phys_inidat( cam_out, pbuf2d ) if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' end if - deallocate(tptr3d) - allocate(tptr3d(pcols,pver,begchunk:endchunk)) - - fieldname = 'CONCLD' - m = pbuf_get_index('CONCLD',ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - deallocate (tptr3d) - end if - call initialize_short_lived_species(fh_ini, pbuf2d) !--------------------------------------------------------------------------------- @@ -711,7 +698,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) !----------------------------------------------------------------------- use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index - use physconst, only: rair, cpair, gravit, zvir, karman + use physconst, only: rair, cpair, gravit, zvir, & + karman use cam_thermo, only: cam_thermo_init use ref_pres, only: pref_edge, pref_mid @@ -731,27 +719,24 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use cldfrc2m, only: cldfrc2m_init use co2_cycle, only: co2_init, co2_transport use convect_deep, only: convect_deep_init - use convect_shallow, only: convect_shallow_init + use convect_diagnostics,only: convect_diagnostics_init use cam_diagnostics, only: diag_init use gw_drag, only: gw_init - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_init - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_init use radheat, only: radheat_init use radiation, only: radiation_init use cloud_diagnostics, only: cloud_diagnostics_init - use rk_stratiform, only: rk_stratiform_init use wv_saturation, only: wv_sat_init use microp_driver, only: microp_driver_init use microp_aero, only: microp_aero_init use macrop_driver, only: macrop_driver_init use conv_water, only: conv_water_init - use spcam_drivers, only: spcam_init use tracers, only: tracers_init use aoa_tracers, only: aoa_tracers_init use rayleigh_friction, only: rayleigh_friction_init use pbl_utils, only: pbl_utils_init use vertical_diffusion, only: vertical_diffusion_init use phys_debug_util, only: phys_debug_init + use phys_debug, only: phys_debug_state_init use rad_constituents, only: rad_cnst_init use aer_rad_props, only: aer_rad_props_init use subcol, only: subcol_init @@ -766,7 +751,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) use clubb_intr, only: clubb_ini_cam - use sslt_rebin, only: sslt_rebin_init use tropopause, only: tropopause_init use solar_data, only: solar_data_init use dadadj_cam, only: dadadj_init @@ -774,9 +758,8 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init use cam_history, only: addfld, register_vector_field, add_default - use phys_control, only: phys_getopts - use phys_grid_ctem, only: phys_grid_ctem_init use cam_budget, only: cam_budget_init + use phys_grid_ctem, only: phys_grid_ctem_init ! Input/output arguments type(physics_state), pointer :: phys_state(:) @@ -794,6 +777,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! temperature, water vapor, cloud ! ice, cloud liquid, U, V integer :: history_budget_histfile_num ! output history file number for budget fields + !----------------------------------------------------------------------- call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) @@ -845,9 +829,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! low level, so init it early. Must at least do this before radiation. call wv_sat_init - ! CAM3 prescribed aerosols - if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) - ! Initialize rad constituents and their properties call rad_cnst_init() call aer_rad_props_init() @@ -878,9 +859,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call co2_init() end if - ! CAM3 prescribed ozone - if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) - call gw_init() call rayleigh_friction_init() @@ -902,30 +880,21 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call radheat_init(pref_mid) - call convect_shallow_init(pref_edge, pbuf2d) + call convect_diagnostics_init call cldfrc_init() call cldfrc2m_init() call convect_deep_init(pref_edge) - if( microp_scheme == 'RK' ) then - call rk_stratiform_init() - elseif( microp_scheme == 'MG' ) then - if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) - call microp_aero_init(phys_state,pbuf2d) - call microp_driver_init(pbuf2d) - call conv_water_init - elseif( microp_scheme == 'SPCAM_m2005') then - call conv_water_init - end if - + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) + call microp_aero_init(phys_state,pbuf2d) + call microp_driver_init(pbuf2d) + call conv_water_init ! initiate CLUBB within CAM if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) - call spcam_init(pbuf2d) - call qbo_init call lunar_tides_init() @@ -939,7 +908,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) #if ( defined OFFLINE_DYN ) call metdata_phys_init() #endif - call sslt_rebin_init() call tropopause_init() call dadadj_init() @@ -949,6 +917,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) snow_sh_idx = pbuf_get_index('SNOW_SH') dlfzm_idx = pbuf_get_index('DLFZM', ierr) + cmfmczm_idx = pbuf_get_index('CMFMC_DP', ierr) call phys_getopts(prog_modal_aero_out=prog_modal_aero) @@ -959,7 +928,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) if (clim_modal_aero) then ! If climate calculations are affected by prescribed modal aerosols, the - ! the initialization routine for the dry mode radius calculation is called + ! initialization routine for the dry mode radius calculation is called ! here. For prognostic MAM the initialization is called from ! modal_aero_initialize if (.not. prog_modal_aero) then @@ -1068,8 +1037,6 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) use time_manager, only: get_nstep use cam_diagnostics,only: diag_allocate, diag_physvar_ic use check_energy, only: check_energy_gmean - use phys_control, only: phys_getopts - use spcam_drivers, only: tphysbc_spcam use spmd_utils, only: mpicom use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate #if (defined BFB_CAM_SCAM_IOP ) @@ -1097,8 +1064,8 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) !---------------------------Local workspace----------------------------- ! integer :: c ! indices + integer :: ncol ! number of columns integer :: nstep ! current timestep number - logical :: use_spcam type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) call t_startf ('physpkg_st1') @@ -1152,8 +1119,6 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) call t_startf ('bc_physics') call t_adj_detailf(+1) - call phys_getopts( use_spcam_out = use_spcam) - !$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) do c=begchunk, endchunk ! @@ -1165,16 +1130,9 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) call t_stopf ('diag_physvar_ic') - if (use_spcam) then - call tphysbc_spcam (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) - else - call tphysbc (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) - end if - + call tphysbc (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) end do call t_adj_detailf(-1) @@ -1305,13 +1263,13 @@ end subroutine phys_run2 ! subroutine phys_final( phys_state, phys_tend, pbuf2d ) - use physics_buffer, only : physics_buffer_desc, pbuf_deallocate - use chemistry, only : chem_final - use carma_intr, only : carma_final - use wv_saturation, only : wv_sat_final - use microp_aero, only : microp_aero_final - use phys_grid_ctem, only : phys_grid_ctem_final - use nudging, only: Nudge_Model, nudging_final + use physics_buffer, only: physics_buffer_desc, pbuf_deallocate + use chemistry, only: chem_final + use carma_intr, only: carma_final + use wv_saturation, only: wv_sat_final + use microp_aero, only: microp_aero_final + use phys_grid_ctem, only: phys_grid_ctem_final + use nudging, only: Nudge_Model, nudging_final !----------------------------------------------------------------------- ! @@ -1349,6 +1307,9 @@ subroutine tphysac (ztodt, cam_in, & ! Computes the following: ! ! o Aerosol Emission at Surface + ! o Stratiform Macro-Microphysics + ! o Wet Scavenging of Aerosol + ! o Radiation ! o Source-Sink for Advected Tracers ! o Symmetric Turbulence Scheme - Vertical Diffusion ! o Rayleigh Friction @@ -1360,24 +1321,18 @@ subroutine tphysac (ztodt, cam_in, & ! o Scale Dry Mass Energy !----------------------------------------------------------------------- use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx - use shr_kind_mod, only: r8 => shr_kind_r8 use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions use cam_diagnostics, only: diag_phys_tend_writeout use gw_drag, only: gw_tend use vertical_diffusion, only: vertical_diffusion_tend use rayleigh_friction, only: rayleigh_friction_tend - use constituents, only: cnst_get_ind - use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & - physics_dme_adjust, set_dry_to_wet, physics_state_check, & + use physics_types, only: physics_dme_adjust, set_dry_to_wet, physics_state_check, & dyn_te_idx use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X use aoa_tracers, only: aoa_tracers_timestep_tend - use physconst, only: rhoh2o, latvap,latice - use dyn_tests_utils, only: vc_dycore + use physconst, only: rhoh2o use aero_model, only: aero_model_drydep - use carma_intr, only: carma_emission_tend, carma_timestep_tend - use carma_flags_mod, only: carma_do_aerosol, carma_do_emission use check_energy, only: check_energy_chng, tot_energy_phys use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng use time_manager, only: get_nstep @@ -1391,14 +1346,36 @@ subroutine tphysac (ztodt, cam_in, & use iondrag, only: iondrag_calc, do_waccm_ions use perf_mod use flux_avg, only: flux_avg_run - use unicon_cam, only: unicon_cam_org_diags - use cam_history, only: outfld + use cam_history, only: hist_fld_active, outfld use qneg_module, only: qneg4 use co2_cycle, only: co2_cycle_set_ptend use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend use cam_snapshot, only: cam_snapshot_all_outfld_tphysac use cam_snapshot_common,only: cam_snapshot_ptend_outfld use lunar_tides, only: lunar_tides_tend + use ssatcontrail, only: ssatcontrail_d0 + use physics_types, only: physics_ptend_init, physics_ptend_sum, physics_ptend_scale + use microp_driver, only: microp_driver_tend + use microp_aero, only: microp_aero_run + use clubb_intr, only: clubb_tend_cam, clubb_emissions_cam + use subcol, only: subcol_gen, subcol_ptend_avg + use subcol_utils, only: subcol_ptend_copy, is_subcol_on + use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol + use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv + use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim + use micro_pumas_cam, only: massless_droplet_destroyer + use convect_deep, only: convect_deep_tend_2, deep_scheme_does_scav_trans + use cloud_diagnostics, only: cloud_diagnostics_calc + use radiation, only: radiation_tend + use tropopause, only: tropopause_output + use cam_diagnostics, only: diag_phys_writeout, diag_conv, diag_clip_tend_writeout + use aero_model, only: aero_model_wetdep + use physics_buffer, only: col_type_subcol + use check_energy, only: check_energy_timestep_init + use carma_intr, only: carma_wetdep_tend, carma_timestep_tend, carma_emission_tend + use carma_flags_mod, only: carma_do_aerosol, carma_do_emission, carma_do_detrain + use carma_flags_mod, only: carma_do_cldice, carma_do_cldliq, carma_do_wetdep + use dyn_tests_utils, only: vc_dycore use cam_thermo, only: cam_thermo_water_update use cam_budget, only: thermo_budget_history use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure @@ -1415,23 +1392,75 @@ subroutine tphysac (ztodt, cam_in, & type(physics_buffer_desc), pointer :: pbuf(:) - type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes + type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes ! !---------------------------Local workspace----------------------------- ! - type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps + type(physics_state) :: state_sc ! state for sub-columns + type(physics_ptend) :: ptend_sc ! ptend for sub-columns + type(physics_ptend) :: ptend_aero ! ptend for microp_aero + type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns + type(physics_tend) :: tend_sc ! tend for sub-columns + + integer :: nstep ! current timestep number + real(r8) :: zero(pcols) ! array of zeros + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer i,k,m ! Longitude, level indices + integer :: yr, mon, day, tod ! components of a date + integer :: ixq, ixcldice, ixcldliq ! constituent indices for vapor, cloud liquid and ice water. + + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep + + real(r8) :: net_flx(pcols) + + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) rtdt ! 1./ztodt + + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: flx_cnd(pcols) + + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: zero_tracers(pcols,pcnst) + + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + real(r8), pointer :: cmfmczm(:,:) ! ZM convective mass fluxes + real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid + + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - integer :: nstep ! current timestep number - real(r8) :: zero(pcols) ! array of zeros + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k ! Longitude, level indices - integer :: ixq + ! carma precipitation variables + real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) + real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) - logical :: labort ! abort flag + logical :: labort ! abort flag + real(r8) tvm(pcols,pver) ! virtual temperature + real(r8) prect(pcols) ! total precipitation real(r8) surfric(pcols) ! surface friction velocity real(r8) obklen(pcols) ! Obukhov length real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry @@ -1462,7 +1491,7 @@ subroutine tphysac (ztodt, cam_in, & ncol = state%ncol nstep = get_nstep() - call cnst_get_ind('Q', ixq) + rtdt = 1._r8/ztodt ! Adjust the surface fluxes to reduce instabilities in near sfc layer if (phys_do_flux_avg()) then @@ -1470,8 +1499,9 @@ subroutine tphysac (ztodt, cam_in, & endif ! Validate the physics state. - if (state_debug_checks) & - call physics_state_check(state, name="before tphysac") + if (state_debug_checks) then + call physics_state_check(state, name="before tphysac") + end if call t_startf('tphysac_init') ! Associate pointers with physics buffer fields @@ -1494,6 +1524,39 @@ subroutine tphysac (ztodt, cam_in, & ifld = pbuf_get_index('AST') call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call cnst_get_ind('Q', ixq) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (is_subcol_on()) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + if (cmfmczm_idx > 0) then + call pbuf_get_field(pbuf, cmfmczm_idx, cmfmczm) + cmfmc(:ncol,:) = cmfmczm(:ncol,:) + else + cmfmc(:ncol,:) = 0._r8 + end if + + call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) + rliq(:ncol) = rliqbc(:ncol) + ! ! accumulate fluxes into net flux array for spectral dycores ! jrm Include latent heat of fusion for snow @@ -1508,12 +1571,12 @@ subroutine tphysac (ztodt, cam_in, & if (trim(cam_take_snapshot_before) == "chem_emissions") then call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if call chem_emissions( state, cam_in ) if (trim(cam_take_snapshot_after) == "chem_emissions") then call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if if (carma_do_emission) then @@ -1524,6 +1587,8 @@ subroutine tphysac (ztodt, cam_in, & ! get nstep and zero array for energy checker zero = 0._r8 + zero_sc(:) = 0._r8 + zero_tracers(:,:) = 0._r8 nstep = get_nstep() call check_tracers_init(state, tracerint) @@ -1535,1343 +1600,1251 @@ subroutine tphysac (ztodt, cam_in, & cam_in%shf, cam_in%lhf, cam_in%cflx) call t_stopf('tphysac_init') + !=================================================== - ! Source/sink terms for advected tracers. + ! Apply tracer surface fluxes to lowest model layer !=================================================== - call t_startf('adv_tracer_src_snk') - ! Test tracers + call t_startf('clubb_emissions_tend') - if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) - if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & - cam_in%cflx) + call clubb_emissions_cam(state, cam_in, ptend) - if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - call co2_cycle_set_ptend(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + + call check_energy_chng(state, tend, "clubb_emissions_tend", nstep, ztodt, zero, zero, zero, zero) + + call t_stopf('clubb_emissions_tend') !=================================================== - ! Chemistry and MAM calculation - ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. - ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and - ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before - ! Gas chemistry and MAM core aerosol conversion. - ! Note that surface flux is not added into the atmosphere, but elevated emission is - ! added into the atmosphere as tendency. + ! Calculate tendencies from CARMA bin microphysics. !=================================================== - if (chem_is_active()) then + ! + ! If CARMA is doing detrainment, then on output, rliq no longer represents + ! water reserved + ! for detrainment, but instead represents potential snow fall. The mass and + ! number of the + ! snow are stored in the physics buffer and will be incorporated by the MG + ! microphysics. + ! + ! Currently CARMA cloud microphysics is only supported with the MG + ! microphysics. + call t_startf('carma_timestep_tend') - if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) + if (carma_do_cldice .or. carma_do_cldliq) then + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & + prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) + call physics_update(state, ptend, ztodt, tend) + + ! Before the detrainment, the reserved condensate is all liquid, but if + ! CARMA is doing + ! detrainment, then the reserved condensate is snow. + if (carma_do_detrain) then + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) + else + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) end if + end if - call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & - pbuf, fh2o=fh2o) + call t_stopf('carma_timestep_tend') + if( microp_scheme == 'MG' ) then + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps - if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 + + ! contrail parameterization + ! see Chen et al., 2012: Global contrail coverage simulated + ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES + ! https://doi.org/10.1029/2011MS000105 + call ssatcontrail_d0(state, pbuf, ztodt, ptend) call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) - call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & - cam_in%cflx) - end if - call t_stopf('adv_tracer_src_snk') + ! initialize ptend structures where macro and microphysics tendencies are + ! accumulated over macmic substeps + call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) - !=================================================== - ! Vertical diffusion/pbl calculation - ! Call vertical diffusion code (pbl, free atmosphere and molecular) - !=================================================== + do macmic_it = 1, cld_macmic_num_steps - call t_startf('vertical_diffusion_tend') + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== - if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + call t_startf('macrop_tend') - call vertical_diffusion_tend (ztodt ,state , cam_in, & - surfric ,obklen ,ptend ,ast ,pbuf ) + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== - !------------------------------------------ - ! Call major diffusion for extended model - !------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_tend (ztodt ,state ,ptend) - endif + if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - - call t_stopf ('vertical_diffusion_tend') - - !=================================================== - ! Rayleigh friction calculation - !=================================================== - call t_startf('rayleigh_friction') - call rayleigh_friction_tend( ztodt, state, ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - call t_stopf('rayleigh_friction') - - if (do_clubb_sgs) then - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) - else - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & - zero, cam_in%shf) - endif - - call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) - - ! aerosol dry deposition processes - call t_startf('aero_drydep') - - if (trim(cam_take_snapshot_before) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - - call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) - if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - - if (trim(cam_take_snapshot_after) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - - call t_stopf('aero_drydep') - - ! CARMA microphysics - ! - ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing the dry - ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, so that - ! obklen and surfric have been calculated. It needs to follow aero_model_drydep, so - ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and cam_out - ! can be added to for CARMA aerosols. - if (carma_do_aerosol) then - call t_startf('carma_timestep_tend') - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) - call physics_update(state, ptend, ztodt, tend) - - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) - call t_stopf('carma_timestep_tend') - end if + call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - !--------------------------------------------------------------------------------- - ! ... enforce charge neutrality - !--------------------------------------------------------------------------------- - call charge_balance(state, pbuf) + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - !=================================================== - ! Gravity wave drag - !=================================================== - call t_startf('gw_tend') + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_ptend_sum(ptend,ptend_macp_all,ncol) + call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_before) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) + ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code + call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) - if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + call t_stopf('macrop_tend') - if (trim(cam_take_snapshot_after) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + !=================================================== + ! Calculate cloud microphysics + !=================================================== - ! Check energy integrals - call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & - zero, zero, flx_heat) - call t_stopf('gw_tend') + if (is_subcol_on() .neqv. use_subcol_microp ) then + call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") + end if - ! QBO relaxation + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) - if (trim(cam_take_snapshot_before) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + ! Generate sub-columns using the requested scheme + if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) - call qbo_relax(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if - if (trim(cam_take_snapshot_after) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + if (trim(cam_take_snapshot_before) == "microp_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! Check energy integrals - call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') - ! Lunar tides - call lunar_tides_tend( state, ptend ) - if ( ptend%lu ) then - call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - ! Check energy integrals - call check_energy_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) + call t_startf('microp_tend') - ! Ion drag calculation - call t_startf ( 'iondrag' ) + if (use_subcol_microp) then - if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - if ( do_waccm_ions ) then - call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) - else - call iondrag_calc( lchnk, ncol, state, ptend) - endif - !---------------------------------------------------------------------------- - ! Call ionosphere routines for extended model if mode is set to ionosphere - !---------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) - endif + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) + ! Parameterize subcolumn effects on covariances, if enabled + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) - if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + ! Call the conservative hole filler. + ! Hole filling is only necessary when using subcolumns. + ! Note: this needs to be called after subcol_ptend_avg but before + ! physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & + ptend, pbuf ) - call tot_energy_phys(state, 'phAP') - call tot_energy_phys(state, 'dyAP',vc=vc_dycore) + ! Destroy massless droplets - Note this routine returns with no change unless + ! micro_do_massless_droplet_destroyer has been set to true + call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) + ptend ) ! Intent(inout) - !--------------------------------------------------------------------------------- - ! Enforce charge neutrality after O+ change from ionos_tend - !--------------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call charge_balance(state, pbuf) - endif + ! Limit the value of hydrometeor concentrations in order to place + ! reasonable limits on hydrometeor drop size and keep them from + ! becoming too large. + ! Note: this needs to be called after hydrometeor mixing ratio + ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv + ! and after massless drop concentrations are removed by the + ! subcol_SILHS_massless_droplet_destroyer, but before the + ! call to physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) - ! Check energy integrals - call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) - call t_stopf ( 'iondrag' ) + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) - ! Update Nudging values, if needed - !---------------------------------- - if((Nudge_Model).and.(Nudge_ON)) then - call nudging_timestep_tend(state,ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) - end if - call physics_update(state,ptend,ztodt,tend) - call check_energy_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) - endif + if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) - !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! Save total energy for global fixer in next timestep - ! - ! This call must be after the last parameterization and call to physics_update - ! - call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, & + prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & + snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) - if (shallow_scheme .eq. 'UNICON') then + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) - ! ------------------------------------------------------------------------ - ! Insert the organization-related heterogeneities computed inside the - ! UNICON into the tracer arrays here before performing advection. - ! This is necessary to prevent any modifications of organization-related - ! heterogeneities by non convection-advection process, such as - ! dry and wet deposition of aerosols, MAM, etc. - ! Again, note that only UNICON and advection schemes are allowed to - ! changes to organization at this stage, although we can include the - ! effects of other physical processes in future. - ! ------------------------------------------------------------------------ + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - call unicon_cam_org_diags(state, pbuf) + call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) - end if - ! - ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust - ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. - moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') - ! - ! update cp/cv for energy computation based in updated water variables - ! - call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& - to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state, ptend, ztodt, tend) - ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. - ! So, save off tracers - if (.not.moist_mixing_ratio_dycore) then - ! - ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core - ! - ! only compute dme_adjust for diagnostics purposes - ! - if (thermo_budget_history) then - tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) - tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) - tmp_ps(:ncol) = state%ps(:ncol) - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - ! Restore pre-"physics_dme_adjust" tracers - state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) - state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) - state%ps(:ncol) = tmp_ps(:ncol) - end if - else - ! - ! for moist-mixing ratio based dycores - ! - ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call - ! - call set_dry_to_wet(state) + if (trim(cam_take_snapshot_after) == "microp_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat) - end if + call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & + zero, prec_str(:ncol)/cld_macmic_num_steps, & + snow_str(:ncol)/cld_macmic_num_steps, zero) - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - endif + call t_stopf('microp_tend') - if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then - ! - ! MPAS and SE specific scaling of temperature for enforcing energy consistency - ! (and to make sure that temperature dependent diagnostic tendencies - ! are computed correctly; e.g. dtcore) - ! - scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) - state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& - scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) - tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) - ! - ! else: do nothing for dycores with energy consistent with CAM physics - ! - end if + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + end do ! end substepping over macrophysics/microphysics - ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep - do k = 1,pver - dtcore(:ncol,k) = state%t(:ncol,k) - dqcore(:ncol,k) = state%q(:ncol,k,ixq) - ducore(:ncol,k) = state%u(:ncol,k) - dvcore(:ncol,k) = state%v(:ncol,k) - end do + call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) + call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) + call physics_ptend_dealloc(ptend_macp_all) - !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) - if (aqua_planet) then - labort = .false. - do i=1,ncol - if (cam_in%ocnfrac(i) /= 1._r8) then - labort = .true. - if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) - end if - end do - if (labort) then - call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') - endif endif - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) + ! Add the precipitation from CARMA to the precipitation from stratiform. + if (carma_do_cldice .or. carma_do_cldliq) then + prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) + snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) + end if - call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) + if ( .not. deep_scheme_does_scav_trans() ) then - end subroutine tphysac + ! ------------------------------------------------------------------------------- + ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. + ! 2. Convective Transport of Non-Water Aerosol Species. + ! + ! . Aerosol wet chemistry determines scavenging fractions, and transformations + ! . Then do convective transport of all trace species except qv,ql,qi. + ! . We needed to do the scavenging first to determine the interstitial fraction. + ! . When UNICON is used as unified convection, we should still perform + ! wet scavenging but not 'convect_deep_tend2'. + ! ------------------------------------------------------------------------------- - subroutine tphysbc (ztodt, state, & - tend, pbuf, & - cam_out, cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Evaluate and apply physical processes that are calculated BEFORE - ! coupling to land, sea, and ice models. - ! - ! Processes currently included are: - ! - ! o Resetting Negative Tracers to Positive - ! o Global Mean Total Energy Fixer - ! o Dry Adjustment - ! o Asymmetric Turbulence Scheme : Deep Convection & Shallow Convection - ! o Stratiform Macro-Microphysics - ! o Wet Scavenging of Aerosol - ! o Radiation - ! - ! Method: - ! - ! Each parameterization should be implemented with this sequence of calls: - ! 1) Call physics interface - ! 2) Check energy - ! 3) Call physics_update - ! See Interface to Column Physics and Chemistry Packages - ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html - ! - !----------------------------------------------------------------------- + call t_startf('bc_aerosols') + if (clim_modal_aero .and. .not. prog_modal_aero) then + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + endif - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx - use physics_buffer, only: col_type_subcol, dyn_time_lvls - use shr_kind_mod, only: r8 => shr_kind_r8 + if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - use dadadj_cam, only: dadadj_tend - use rk_stratiform, only: rk_stratiform_tend - use microp_driver, only: microp_driver_tend - use microp_aero, only: microp_aero_run - use macrop_driver, only: macrop_driver_tend - use physics_types, only: physics_state, physics_tend, physics_ptend, & - physics_update, physics_ptend_init, physics_ptend_sum, & - physics_state_check, physics_ptend_scale, & - dyn_te_idx - use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write - use cam_diagnostics, only: diag_clip_tend_writeout - use cam_history, only: outfld - use physconst, only: latvap - use constituents, only: pcnst, qmin, cnst_get_ind - use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx - use convect_deep, only: convect_deep_tend, convect_deep_tend_2, deep_scheme_does_scav_trans - use time_manager, only: is_first_step, get_nstep - use convect_shallow, only: convect_shallow_tend - use check_energy, only: check_energy_chng, check_energy_fix, check_energy_timestep_init - use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng - use check_energy, only: tot_energy_phys - use dycore, only: dycore_is - use aero_model, only: aero_model_wetdep - use carma_intr, only: carma_wetdep_tend, carma_timestep_tend - use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep - use radiation, only: radiation_tend - use cloud_diagnostics, only: cloud_diagnostics_calc - use perf_mod - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_adj - use clubb_intr, only: clubb_tend_cam - use sslt_rebin, only: sslt_rebin_adv - use tropopause, only: tropopause_output - use cam_abortutils, only: endrun - use subcol, only: subcol_gen, subcol_ptend_avg - use subcol_utils, only: subcol_ptend_copy, is_subcol_on - use qneg_module, only: qneg3 - use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol - use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv - use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim - use micro_pumas_cam, only: massless_droplet_destroyer - use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc - use cam_snapshot_common, only: cam_snapshot_ptend_outfld - use ssatcontrail, only: ssatcontrail_d0 - use dyn_tests_utils, only: vc_dycore + call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) + if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - ! Arguments + if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + if (carma_do_wetdep) then + ! CARMA wet deposition + ! + ! NOTE: It needs to follow aero_model_wetdep, so that + ! cam_out%xxxwetxxx + ! fields have already been set for CAM aerosols and cam_out can be + ! added + ! to for CARMA aerosols. + call t_startf ('carma_wetdep_tend') + call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('carma_wetdep_tend') + end if - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) + call t_startf ('convect_deep_tend2') + call convect_deep_tend_2( state, ptend, ztodt, pbuf ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('convect_deep_tend2') - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in + ! check tracer integrals + call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) + call t_stopf('bc_aerosols') - ! - !---------------------------Local workspace----------------------------- - ! + endif - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps - type(physics_state) :: state_sc ! state for sub-columns - type(physics_ptend) :: ptend_sc ! ptend for sub-columns - type(physics_ptend) :: ptend_aero ! ptend for microp_aero - type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns - type(physics_tend) :: tend_sc ! tend for sub-columns + !=================================================== + ! Moist physical parameteriztions complete: + ! send dynamical variables, and derived variables to history file + !=================================================== - integer :: nstep ! current timestep number + call t_startf('bc_history_write') + call diag_phys_writeout(state, pbuf) + call diag_conv(state, ztodt, pbuf) - real(r8) :: net_flx(pcols) + call t_stopf('bc_history_write') - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + !=================================================== + ! Write cloud diagnostics on history file + !=================================================== - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + call t_startf('bc_cld_diag_history_write') - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev - real(r8) rtdt ! 1./ztodt + call cloud_diagnostics_calc(state, pbuf) - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns + call t_stopf('bc_cld_diag_history_write') - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. - integer :: m, m_cnst - ! for macro/micro co-substepping - integer :: macmic_it ! iteration variables - real(r8) :: cld_macmic_ztodt ! modified timestep - ! physics buffer fields to compute tendencies for stratiform package - integer itim_old, ifld - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction + !=================================================== + ! Radiation computations + !=================================================== + call t_startf('radiation') + if (trim(cam_take_snapshot_before) == "radiation_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! physics buffer fields for total energy and mass adjustment - real(r8), pointer, dimension(: ) :: teout - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: totliqini - real(r8), pointer, dimension(:,:) :: toticeini - real(r8), pointer, dimension(:,:) :: dtcore - real(r8), pointer, dimension(:,:) :: dqcore - real(r8), pointer, dimension(:,:) :: ducore - real(r8), pointer, dimension(:,:) :: dvcore + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + ! Set net flux used by spectral dycores + do i=1,ncol + tend%flx_net(i) = net_flx(i) + end do - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - ! convective precipitation variables - real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8),pointer :: snow_dp(:) ! snow from ZM convection - real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8),pointer :: snow_sh(:) ! snow from Hack convection + if (trim(cam_take_snapshot_after) == "radiation_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! carma precipitation variables - real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) - real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + call t_stopf('radiation') - ! Local copies for substepping - real(r8) :: prec_pcw_macmic(pcols) - real(r8) :: snow_pcw_macmic(pcols) - real(r8) :: prec_sed_macmic(pcols) - real(r8) :: snow_sed_macmic(pcols) + ! Diagnose the location of the tropopause and its location to the history file(s). + call t_startf('tropopause') + call tropopause_output(state) + call t_stopf('tropopause') - ! energy checking variables - real(r8) :: zero(pcols) ! array of zeros - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice - real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) - type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes - real(r8) :: zero_tracers(pcols,pcnst) + !=================================================== + ! Source/sink terms for advected tracers. + !=================================================== + call t_startf('adv_tracer_src_snk') + ! Test tracers + + if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) + if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & + cam_in%cflx) - !----------------------------------------------------------------------- + if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call co2_cycle_set_ptend(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - call t_startf('bc_init') + !=================================================== + ! Chemistry and MAM calculation + ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. + ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and + ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before + ! Gas chemistry and MAM core aerosol conversion. + ! Note that surface flux is not added into the atmosphere, but elevated emission is + ! added into the atmosphere as tendency. + !=================================================== + if (chem_is_active()) then - zero = 0._r8 - zero_tracers(:,:) = 0._r8 - zero_sc(:) = 0._r8 + if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - lchnk = state%lchnk - ncol = state%ncol + call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & + pbuf, fh2o=fh2o) - rtdt = 1._r8/ztodt - nstep = get_nstep() + if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) + if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) + call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & + cam_in%cflx) + end if + call t_stopf('adv_tracer_src_snk') - call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) + !=================================================== + ! Vertical diffusion/pbl calculation + ! Call vertical diffusion (apply tracer emissions, molecular diffusion and pbl form drag) + !=================================================== - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - call pbuf_get_field(pbuf, totliqini_idx, totliqini) - call pbuf_get_field(pbuf, toticeini_idx, toticeini) + call t_startf('vertical_diffusion_tend') - call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ifld = pbuf_get_index('FRACIS') - call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - fracis (:ncol,:,1:pcnst) = 1._r8 + call vertical_diffusion_tend (ztodt ,state , cam_in, & + surfric ,obklen ,ptend ,ast ,pbuf ) - ! Set physics tendencies to 0 - tend %dTdt(:ncol,:pver) = 0._r8 - tend %dudt(:ncol,:pver) = 0._r8 - tend %dvdt(:ncol,:pver) = 0._r8 + !------------------------------------------ + ! Call major diffusion for extended model + !------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_tend (ztodt ,state ,ptend) + endif - ! Verify state coming from the dynamics - if (state_debug_checks) & - call physics_state_check(state, name="before tphysbc (dycore?)") + if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) + if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! Since clybry_fam_adj operates directly on the tracers, and has no - ! physics_update call, re-run qneg3. - call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,state%q ) + call t_stopf ('vertical_diffusion_tend') - ! Validate output of clybry_fam_adj. - if (state_debug_checks) & - call physics_state_check(state, name="clybry_fam_adj") + !=================================================== + ! Rayleigh friction calculation + !=================================================== + call t_startf('rayleigh_friction') + call rayleigh_friction_tend( ztodt, state, ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + call t_stopf('rayleigh_friction') - ! - ! Dump out "before physics" state - ! - call diag_state_b4_phys_write (state) + if (do_clubb_sgs) then + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) + else + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & + zero, cam_in%shf) + endif - ! compute mass integrals of input tracers state - call check_tracers_init(state, tracerint) + call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) - call t_stopf('bc_init') + ! aerosol dry deposition processes + call t_startf('aero_drydep') - !=================================================== - ! Global mean total energy fixer - !=================================================== - call t_startf('energy_fixer') + if (trim(cam_take_snapshot_before) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - call tot_energy_phys(state, 'phBF') - call tot_energy_phys(state, 'dyBF',vc=vc_dycore) - if (.not.dycore_is('EUL')) then - call check_energy_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) + call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) + if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) end if - call tot_energy_phys(state, 'phBP') - call tot_energy_phys(state, 'dyBP',vc=vc_dycore) - ! Save state for convective tendency calculations. - call diag_conv_tend_ini(state, pbuf) + call physics_update(state, ptend, ztodt, tend) - call cnst_get_ind('Q', ixq) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - qini (:ncol,:pver) = state%q(:ncol,:pver, 1) - cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + if (trim(cam_take_snapshot_after) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - totliqini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do - toticeini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do + call t_stopf('aero_drydep') + ! CARMA microphysics + ! + ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing + ! the dry + ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, + ! so that + ! obklen and surfric have been calculated. It needs to follow + ! aero_model_drydep, so + ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and + ! cam_out + ! can be added to for CARMA aerosols. + if (carma_do_aerosol) then + call t_startf('carma_timestep_tend') + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) + call physics_update(state, ptend, ztodt, tend) - call outfld('TEOUT', teout , pcols, lchnk ) - call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) - call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('carma_timestep_tend') + end if - ! T, U, V tendency due to dynamics - if( nstep > dyn_time_lvls-1 ) then - dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt - dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt - ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt - dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt - call outfld( 'DTCORE', dtcore, pcols, lchnk ) - call outfld( 'DQCORE', dqcore, pcols, lchnk ) - call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) - call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) - end if + !--------------------------------------------------------------------------------- + ! ... enforce charge neutrality + !--------------------------------------------------------------------------------- + call charge_balance(state, pbuf) - call t_stopf('energy_fixer') - ! !=================================================== - ! Dry adjustment + ! Gravity wave drag !=================================================== - call t_startf('dry_adjustment') + call t_startf('gw_tend') - if (trim(cam_take_snapshot_before) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_before) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if - call dadadj_tend(ztodt, state, ptend) + call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) - if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & + if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if - call t_stopf('dry_adjustment') - - !=================================================== - ! Moist convection - !=================================================== - call t_startf('moist_convection') - - call t_startf ('convect_deep_tend') + ! Check energy integrals + call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & + zero, zero, flx_heat) + call t_stopf('gw_tend') - if (trim(cam_take_snapshot_before) == "convect_deep_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + ! QBO relaxation - call convect_deep_tend( & - cmfmc, cmfcme, & - pflx, zdu, & - rliq, rice, & - ztodt, & - state, ptend, cam_in%landfrac, pbuf) + if (trim(cam_take_snapshot_before) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & + call qbo_relax(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) end if - if ( ptend%lu ) then - call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) + call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) end if if ( ptend%lv ) then - call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) + call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "convect_deep_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if - call t_stopf('convect_deep_tend') - - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + ! Check energy integrals + call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + ! Lunar tides + call lunar_tides_tend( state, ptend ) + if ( ptend%lu ) then + call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) end if - - ! Check energy integrals, including "reserved liquid" - flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) - snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) - call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) - snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) - - ! - ! Call Hack (1994) convection scheme to deal with shallow/mid-level convection - ! - call t_startf ('convect_shallow_tend') - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 + if ( ptend%lv ) then + call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) end if + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) - if (trim(cam_take_snapshot_before) == "convect_shallow_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + ! Ion drag calculation + call t_startf ( 'iondrag' ) + + if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if - call convect_shallow_tend (ztodt , cmfmc, & - dlf , dlf2 , rliq , rliq2, & - state , ptend , pbuf, cam_in) - call t_stopf ('convect_shallow_tend') + if ( do_waccm_ions ) then + call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + else + call iondrag_calc( lchnk, ncol, state, ptend) + endif + !---------------------------------------------------------------------------- + ! Call ionosphere routines for extended model if mode is set to ionosphere + !---------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) + endif - if ( (trim(cam_take_snapshot_after) == "convect_shallow_tend") .and. & + if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) end if if ( ptend%lu ) then - call outfld( 'UTEND_SHCONV', ptend%u, pcols, lchnk) + call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) end if if ( ptend%lv ) then - call outfld( 'VTEND_SHCONV', ptend%v, pcols, lchnk) + call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "convect_shallow_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) end if + call tot_energy_phys(state, 'phAP') + call tot_energy_phys(state, 'dyAP',vc=vc_dycore) - flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) - call check_energy_chng(state, tend, "convect_shallow", nstep, ztodt, zero, flx_cnd, snow_sh, zero) + !--------------------------------------------------------------------------------- + ! Enforce charge neutrality after O+ change from ionos_tend + !--------------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call charge_balance(state, pbuf) + endif - call check_tracers_chng(state, tracerint, "convect_shallow", nstep, ztodt, zero_tracers) + ! Check energy integrals + call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) - call t_stopf('moist_convection') + call t_stopf ( 'iondrag' ) - ! Rebin the 4-bin version of sea salt into bins for coarse and accumulation - ! modes that correspond to the available optics data. This is only necessary - ! for CAM-RT. But it's done here so that the microphysics code which is called - ! from the stratiform interface has access to the same aerosols as the radiation - ! code. - call sslt_rebin_adv(pbuf, state) + ! Update Nudging values, if needed + !---------------------------------- + if((Nudge_Model).and.(Nudge_ON)) then + call nudging_timestep_tend(state,ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) + end if + call physics_update(state,ptend,ztodt,tend) + call check_energy_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) + endif - !=================================================== - ! Calculate tendencies from CARMA bin microphysics. - !=================================================== + !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + ! Save total energy for global fixer in next timestep ! - ! If CARMA is doing detrainment, then on output, rliq no longer represents water reserved - ! for detrainment, but instead represents potential snow fall. The mass and number of the - ! snow are stored in the physics buffer and will be incorporated by the MG microphysics. + ! This call must be after the last parameterization and call to physics_update ! - ! Currently CARMA cloud microphysics is only supported with the MG microphysics. - call t_startf('carma_timestep_tend') - - if (carma_do_cldice .or. carma_do_cldliq) then - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & - prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) - call physics_update(state, ptend, ztodt, tend) - - ! Before the detrainment, the reserved condensate is all liquid, but if CARMA is doing - ! detrainment, then the reserved condensate is snow. - if (carma_do_detrain) then - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) - else - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - end if - end if - - call t_stopf('carma_timestep_tend') - - if( microp_scheme == 'RK' ) then - - !=================================================== - ! Calculate stratiform tendency (sedimentation, detrain, cloud fraction and microphysics ) - !=================================================== - call t_startf('rk_stratiform_tend') - - call rk_stratiform_tend(state, ptend, pbuf, ztodt, & - cam_in%icefrac, cam_in%landfrac, cam_in%ocnfrac, & - cam_in%snowhland, & ! sediment - dlf, dlf2, & ! detrain - rliq , & ! check energy after detrain - cmfmc, & - cam_in%ts, cam_in%sst, zdu) - - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "cldwat_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - - call t_stopf('rk_stratiform_tend') - - elseif( microp_scheme == 'MG' ) then - ! Start co-substepping of macrophysics and microphysics - cld_macmic_ztodt = ztodt/cld_macmic_num_steps - - ! Clear precip fields that should accumulate. - prec_sed_macmic = 0._r8 - snow_sed_macmic = 0._r8 - prec_pcw_macmic = 0._r8 - snow_pcw_macmic = 0._r8 - - ! contrail parameterization - ! see Chen et al., 2012: Global contrail coverage simulated - ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES - ! https://doi.org/10.1029/2011MS000105 - call ssatcontrail_d0(state, pbuf, ztodt, ptend) - call physics_update(state, ptend, ztodt, tend) - - ! initialize ptend structures where macro and microphysics tendencies are - ! accumulated over macmic substeps - call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) - - do macmic_it = 1, cld_macmic_num_steps + call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + ! + ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust + ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. + moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') + ! + ! update cp/cv for energy computation based in updated water variables + ! + call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& + to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) - !=================================================== - ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) - !=================================================== + ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. + ! So, save off tracers + if (.not.moist_mixing_ratio_dycore) then + ! + ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core + ! + ! only compute dme_adjust for diagnostics purposes + ! + if (thermo_budget_history) then + tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) + tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) + tmp_ps(:ncol) = state%ps(:ncol) + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + ! Restore pre-"physics_dme_adjust" tracers + state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) + state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) + state%ps(:ncol) = tmp_ps(:ncol) + end if + else + ! + ! for moist-mixing ratio based dycores + ! + ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call + ! + call set_dry_to_wet(state) - call t_startf('macrop_tend') + if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + end if - ! don't call Park macrophysics if CLUBB is called - if (macrop_scheme .ne. 'CLUBB_SGS') then + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + endif - if (trim(cam_take_snapshot_before) == "macrop_driver_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then + ! + ! MPAS and SE specific scaling of temperature for enforcing energy consistency + ! (and to make sure that temperature dependent diagnostic tendencies + ! are computed correctly; e.g. dtcore) + ! + scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) + state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& + scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) + tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) + ! + ! else: do nothing for dycores with energy consistent with CAM physics + ! + end if - call macrop_driver_tend( & - state, ptend, cld_macmic_ztodt, & - cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment - dlf, dlf2, & ! detrain - cmfmc, & - cam_in%ts, cam_in%sst, zdu, & - pbuf, det_s, det_ice) - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = det_s(:ncol) + ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep + do k = 1,pver + dtcore(:ncol,k) = state%t(:ncol,k) + dqcore(:ncol,k) = state%q(:ncol,k,ixq) + ducore(:ncol,k) = state%u(:ncol,k) + dvcore(:ncol,k) = state%v(:ncol,k) + end do - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - if ( (trim(cam_take_snapshot_after) == "macrop_driver_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_ptend_sum(ptend,ptend_macp_all,ncol) - call physics_update(state, ptend, ztodt, tend) + !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - if (trim(cam_take_snapshot_after) == "macrop_driver_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + if (aqua_planet) then + labort = .false. + do i=1,ncol + if (cam_in%ocnfrac(i) /= 1._r8) then + labort = .true. + if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) + end if + end do + if (labort) then + call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') + endif + endif - call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & - zero, flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) - else ! Calculate CLUBB macrophysics + call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) - ! ===================================================== - ! CLUBB call (PBL, shallow convection, macrophysics) - ! ===================================================== + end subroutine tphysac - if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + subroutine tphysbc (ztodt, state, & + tend, pbuf, & + cam_out, cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Evaluate and apply physical processes that are calculated BEFORE + ! coupling to land, sea, and ice models. + ! + ! Processes currently included are: + ! + ! o Resetting Negative Tracers to Positive + ! o Global Mean Total Energy Fixer + ! o Dry Adjustment + ! o Asymmetric Turbulence Scheme - Deep Convection & Shallow Convection + ! + ! Method: + ! + ! Each parameterization should be implemented with this sequence of calls: + ! 1) Call physics interface + ! 2) Check energy + ! 3) Call physics_update + ! See Interface to Column Physics and Chemistry Packages + ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html + ! + !----------------------------------------------------------------------- - call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) + use physics_buffer, only: physics_buffer_desc, pbuf_get_field + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx + use physics_buffer, only: col_type_subcol, dyn_time_lvls - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + use dadadj_cam, only: dadadj_tend + use physics_types, only: physics_update, & + physics_state_check, & + dyn_te_idx + use cam_diagnostics, only: diag_conv_tend_ini, diag_conv, diag_export, diag_state_b4_phys_write + use cam_history, only: outfld + use constituents, only: qmin + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx + use convect_deep, only: convect_deep_tend + use time_manager, only: is_first_step, get_nstep + use convect_diagnostics,only: convect_diagnostics_calc + use check_energy, only: check_energy_chng, check_energy_fix + use check_energy, only: check_tracers_data, check_tracers_init + use check_energy, only: tot_energy_phys + use dycore, only: dycore_is + use radiation, only: radiation_tend + use perf_mod + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_adj + use cam_abortutils, only: endrun + use subcol_utils, only: is_subcol_on + use qneg_module, only: qneg3 + use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc + use cam_snapshot_common, only: cam_snapshot_ptend_outfld + use dyn_tests_utils, only: vc_dycore - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + ! Arguments - ! Update physics tendencies and copy state to state_eq, because that is - ! input for microphysics - if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_ptend_sum(ptend,ptend_macp_all,ncol) - call physics_update(state, ptend, ztodt, tend) + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) - ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code - call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & - cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in - endif - call t_stopf('macrop_tend') + ! + !---------------------------Local workspace----------------------------- + ! - !=================================================== - ! Calculate cloud microphysics - !=================================================== + type(physics_ptend) :: ptend ! indivdual parameterization tendencies - if (is_subcol_on() .neqv. use_subcol_microp ) then - call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") - end if + integer :: nstep ! current timestep number - if (is_subcol_on()) then - ! Allocate sub-column structures. - call physics_state_alloc(state_sc, lchnk, psubcols*pcols) - call physics_tend_alloc(tend_sc, psubcols*pcols) + real(r8) :: net_flx(pcols) - ! Generate sub-columns using the requested scheme - if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) - call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - !Initialize check energy for subcolumns - call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) - end if + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - if (trim(cam_take_snapshot_before) == "microp_section") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev + real(r8) rtdt ! 1./ztodt - call t_startf('microp_aero_run') - call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) - call t_stopf('microp_aero_run') + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns - call t_startf('microp_tend') + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + integer :: m, m_cnst - if (use_subcol_microp) then + ! physics buffer fields to compute tendencies for stratiform package + integer itim_old, ifld + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + ! physics buffer fields for total energy and mass adjustment + real(r8), pointer, dimension(: ) :: teout + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: totliqini + real(r8), pointer, dimension(:,:) :: toticeini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: dqcore + real(r8), pointer, dimension(:,:) :: ducore + real(r8), pointer, dimension(:,:) :: dvcore - call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) - ! Parameterize subcolumn effects on covariances, if enabled - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero - call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. + real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid - ! Call the conservative hole filler. - ! Hole filling is only necessary when using subcolumns. - ! Note: this needs to be called after subcol_ptend_avg but before - ! physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & - ptend, pbuf ) + ! convective precipitation variables + real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8),pointer :: snow_dp(:) ! snow from ZM convection + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection - ! Destroy massless droplets - Note this routine returns with no change unless - ! micro_do_massless_droplet_destroyer has been set to true - call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) - ptend ) ! Intent(inout) + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - ! Limit the value of hydrometeor concentrations in order to place - ! reasonable limits on hydrometeor drop size and keep them from - ! becoming too large. - ! Note: this needs to be called after hydrometeor mixing ratio - ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv - ! and after massless drop concentrations are removed by the - ! subcol_SILHS_massless_droplet_destroyer, but before the - ! call to physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) + ! energy checking variables + real(r8) :: zero(pcols) ! array of zeros + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: flx_cnd(pcols) + real(r8) :: flx_heat(pcols) + type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes + real(r8) :: zero_tracers(pcols,pcnst) - ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend - call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) - call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) - call physics_ptend_dealloc(ptend_aero_sc) + logical :: lq(pcnst) - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) + !----------------------------------------------------------------------- - if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + call t_startf('bc_init') - if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + zero = 0._r8 + zero_tracers(:,:) = 0._r8 + zero_sc(:) = 0._r8 - call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & - nstep, ztodt, zero_sc, & - prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & - snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) + lchnk = state%lchnk + ncol = state%ncol - call physics_state_dealloc(state_sc) - call physics_tend_dealloc(tend_sc) - call physics_ptend_dealloc(ptend_sc) - else - call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) - end if - ! combine aero and micro tendencies for the grid - call physics_ptend_sum(ptend_aero, ptend, ncol) - call physics_ptend_dealloc(ptend_aero) + rtdt = 1._r8/ztodt - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + nstep = get_nstep() - call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) - if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state, ptend, ztodt, tend) + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) - if (trim(cam_take_snapshot_after) == "microp_section") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + call pbuf_get_field(pbuf, totliqini_idx, totliqini) + call pbuf_get_field(pbuf, toticeini_idx, toticeini) - call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & - zero, prec_str(:ncol)/cld_macmic_num_steps, & - snow_str(:ncol)/cld_macmic_num_steps, zero) + call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call t_stopf('microp_tend') - prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) - snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) - prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) - snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + ifld = pbuf_get_index('FRACIS') + call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + fracis (:ncol,:,1:pcnst) = 1._r8 - end do ! end substepping over macrophysics/microphysics + ! Set physics tendencies to 0 + tend%dTdt(:ncol,:pver) = 0._r8 + tend%dudt(:ncol,:pver) = 0._r8 + tend%dvdt(:ncol,:pver) = 0._r8 - call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) - call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) - call physics_ptend_dealloc(ptend_macp_all) + ! Verify state coming from the dynamics + if (state_debug_checks) then + call physics_state_check(state, name="before tphysbc (dycore?)") + end if - prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps - snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps - prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps - snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps - prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) - snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) - endif + ! Since clybry_fam_adj operates directly on the tracers, and has no + ! physics_update call, re-run qneg3. + call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,state%q ) - ! Add the precipitation from CARMA to the precipitation from stratiform. - if (carma_do_cldice .or. carma_do_cldliq) then - prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) - snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) + ! Validate output of clybry_fam_adj. + if (state_debug_checks) then + call physics_state_check(state, name="clybry_fam_adj") end if + ! + ! Dump out "before physics" state + ! + call diag_state_b4_phys_write (state) - if ( .not. deep_scheme_does_scav_trans() ) then + ! compute mass integrals of input tracers state + call check_tracers_init(state, tracerint) - ! ------------------------------------------------------------------------------- - ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. - ! 2. Convective Transport of Non-Water Aerosol Species. - ! - ! . Aerosol wet chemistry determines scavenging fractions, and transformations - ! . Then do convective transport of all trace species except qv,ql,qi. - ! . We needed to do the scavenging first to determine the interstitial fraction. - ! . When UNICON is used as unified convection, we should still perform - ! wet scavenging but not 'convect_deep_tend2'. - ! ------------------------------------------------------------------------------- + call t_stopf('bc_init') - call t_startf('bc_aerosols') - if (clim_modal_aero .and. .not. prog_modal_aero) then - call modal_aero_calcsize_diag(state, pbuf) - call modal_aero_wateruptake_dr(state, pbuf) - endif + !=================================================== + ! Global mean total energy fixer + !=================================================== + call t_startf('energy_fixer') - if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + call tot_energy_phys(state, 'phBF') + call tot_energy_phys(state, 'dyBF',vc=vc_dycore) - call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) - if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if + if (.not.dycore_is('EUL')) then + call check_energy_fix(state, ptend, nstep, flx_heat) call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) + end if - if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) - end if + call tot_energy_phys(state, 'phBP') + call tot_energy_phys(state, 'dyBP',vc=vc_dycore) + ! Save state for convective tendency calculations. + call diag_conv_tend_ini(state, pbuf) - if (carma_do_wetdep) then - ! CARMA wet deposition - ! - ! NOTE: It needs to follow aero_model_wetdep, so that cam_out%xxxwetxxx - ! fields have already been set for CAM aerosols and cam_out can be added - ! to for CARMA aerosols. - call t_startf ('carma_wetdep_tend') - call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('carma_wetdep_tend') - end if + call cnst_get_ind('Q', ixq) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + qini (:ncol,:pver) = state%q(:ncol,:pver, ixq) + cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - call t_startf ('convect_deep_tend2') - call convect_deep_tend_2( state, ptend, ztodt, pbuf ) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('convect_deep_tend2') + totliqini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do + toticeini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do - ! check tracer integrals - call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) - call t_stopf('bc_aerosols') + call outfld('TEOUT', teout , pcols, lchnk ) + call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) + call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) - endif + ! T, U, V tendency due to dynamics + if ( nstep > dyn_time_lvls-1 ) then + dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt + dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt + ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt + dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt + call outfld( 'DTCORE', dtcore, pcols, lchnk ) + call outfld( 'DQCORE', dqcore, pcols, lchnk ) + call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) + call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) + end if + call t_stopf('energy_fixer') + ! !=================================================== - ! Moist physical parameteriztions complete: - ! send dynamical variables, and derived variables to history file + ! Dry adjustment !=================================================== + call t_startf('dry_adjustment') - call t_startf('bc_history_write') - call diag_phys_writeout(state, pbuf) - call diag_conv(state, ztodt, pbuf) - - call t_stopf('bc_history_write') + if (trim(cam_take_snapshot_before) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if - !=================================================== - ! Write cloud diagnostics on history file - !=================================================== + call dadadj_tend(ztodt, state, ptend) - call t_startf('bc_cld_diag_history_write') + if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - call cloud_diagnostics_calc(state, pbuf) + if (trim(cam_take_snapshot_after) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if - call t_stopf('bc_cld_diag_history_write') + call t_stopf('dry_adjustment') !=================================================== - ! Radiation computations + ! Moist convection !=================================================== - call t_startf('radiation') + call t_startf('moist_convection') - if (trim(cam_take_snapshot_before) == "radiation_tend") then + call t_startf ('convect_deep_tend') + + if (trim(cam_take_snapshot_before) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) - - ! Set net flux used by spectral dycores - do i=1,ncol - tend%flx_net(i) = net_flx(i) - end do + call convect_deep_tend( & + cmfmc, cmfcme, & + pflx, zdu, & + rliq, rice, & + ztodt, & + state, ptend, cam_in%landfrac, pbuf) - if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & + if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + + if ( ptend%lu ) then + call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "radiation_tend") then + if (trim(cam_take_snapshot_after) == "convect_deep_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) end if - call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) + call t_stopf('convect_deep_tend') - call t_stopf('radiation') + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) - ! Diagnose the location of the tropopause and its location to the history file(s). - call t_startf('tropopause') - call tropopause_output(state) - call t_stopf('tropopause') + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + end if + + ! Check energy integrals, including "reserved liquid" + flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) + snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) + call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) + snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) + + !=================================================== + ! Compute convect diagnostics + !=================================================== + + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) + else + dlf(:,:) = 0._r8 + end if + + if (trim(cam_take_snapshot_before) == "convect_diagnostics_calc") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + end if + call convect_diagnostics_calc (ztodt , cmfmc, & + dlf , dlf2 , rliq , rliq2, & + state , pbuf) + if ( (trim(cam_take_snapshot_after) == "convect_diagnostics_calc") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + + ! add reserve liquid to pbuf + call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) + rliqbc(:ncol) = rliq(:ncol) + + call t_stopf('moist_convection') + + if (is_first_step()) then + + !initiailize sedimentation arrays + prec_pcw = 0._r8 + snow_pcw = 0._r8 + prec_sed = 0._r8 + snow_sed = 0._r8 + prec_str = 0._r8 + snow_str = 0._r8 + + if (is_subcol_on()) then + prec_str_sc = 0._r8 + snow_str_sc = 0._r8 + end if + + !=================================================== + ! Run wet deposition routines to intialize aerosols + !=================================================== + + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + + !=================================================== + ! Radiation computations + ! initialize fluxes only, do not update state + !=================================================== + + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) + + end if ! Save atmospheric fields to force surface models call t_startf('cam_export') @@ -2899,8 +2872,6 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use physics_buffer, only: physics_buffer_desc use carma_intr, only: carma_timestep_init use ghg_data, only: ghg_data_timestep_init - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_timestep_init - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_timestep_init use aoa_tracers, only: aoa_tracers_timestep_init use vertical_diffusion, only: vertical_diffusion_ts_init use radheat, only: radheat_timestep_init @@ -2964,12 +2935,6 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) ! prescribed aerosol deposition fluxes call aerodep_flx_adv(phys_state, pbuf2d, cam_out) - ! CAM3 prescribed aerosol masses - if (cam3_aero_data_on) call cam3_aero_data_timestep_init(pbuf2d, phys_state) - - ! CAM3 prescribed ozone data - if (cam3_ozone_data_on) call cam3_ozone_data_timestep_init(pbuf2d, phys_state) - ! Time interpolate data models of gasses in pbuf2d call ghg_data_timestep_init(pbuf2d, phys_state) diff --git a/src/utils/cam_grid_support.F90 b/src/utils/cam_grid_support.F90 index d86c829e77..34c41590bb 100644 --- a/src/utils/cam_grid_support.F90 +++ b/src/utils/cam_grid_support.F90 @@ -1633,7 +1633,7 @@ function cam_grid_get_areawt(id) result(wtvals) nullify(attrptr) gridind = get_cam_grid_index(id) if (gridind > 0) then - select case(cam_grids(gridind)%name) + select case(trim(cam_grids(gridind)%name)) case('GLL') wtname='area_weight_gll' case('EUL') From 55ab657eb6a8eba7e1645cc0fd56c1b02094586c Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 24 Sep 2023 12:52:55 -0600 Subject: [PATCH 03/75] bfb mods --- src/dynamics/se/apply_iop_forcing.F90 | 5 +- src/dynamics/se/dycore/prim_driver_mod.F90 | 118 ++++++++++----------- src/dynamics/se/se_single_column_mod.F90 | 68 ++++-------- src/dynamics/se/stepon.F90 | 21 +++- 4 files changed, 100 insertions(+), 112 deletions(-) diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index 500a092ecc..047e1779ad 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -20,7 +20,7 @@ module apply_iop_forcing_mod !========================================================================= subroutine advance_iop_forcing(scm_dt, ps_in, & ! In - u_in, v_in, t_in, q_in, t_phys_frc,hvcoord, & ! In + u_in, v_in, t_in, q_in, t_phys_frc, q_phys_frc, hvcoord, & ! In u_update, v_update, t_update, q_update) ! Out !----------------------------------------------------------------------- @@ -43,6 +43,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In real(r8), intent(in) :: t_in(plev) ! temperature [K] real(r8), intent(in) :: q_in(plev,pcnst) ! q tracer array [units vary] real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] + real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! temperature forcing from physics [K/s] type (hvcoord_t), intent(in) :: hvcoord real(r8), intent(in) :: scm_dt ! model time step [s] @@ -91,7 +92,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In t_update(k) = t_in(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) do m=1,pcnst - q_update(k,m) = q_in(k,m) + scm_dt*q_lsf(k,m) + q_update(k,m) = q_in(k,m) + scm_dt*(q_phys_frc(k,m) + q_lsf(k,m)) end do enddo diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index c1d35621eb..abd2eecfcc 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -831,66 +831,66 @@ subroutine get_global_ave_surface_pressure(elem, global_ave_ps_inic) deallocate(tmp) end subroutine get_global_ave_surface_pressure -subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & + subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & hybrid, dt, tl, nets, nete) - use control_mod, only: tstep_type, qsplit - use derivative_mod, only: derivative_t - use dimensions_mod, only: np, nlev - use element_mod, only: element_t - use hybvcoord_mod, only: hvcoord_t - use hybrid_mod, only: hybrid_t - use time_mod, only: TimeLevel_t, timelevel_qdp, tevolve - use fvm_control_volume_mod, only: fvm_struct - use cam_thermo, only: get_kappa_dry - use air_composition, only: thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp - use physconst, only: cpair - implicit none - - type (element_t), intent(inout), target :: elem(:) - type(fvm_struct) , intent(inout) :: fvm(:) - type (derivative_t) , intent(in) :: deriv - type (hvcoord_t) :: hvcoord - type (hybrid_t) , intent(in) :: hybrid - real (kind=r8), intent(in) :: dt - type (TimeLevel_t) , intent(in) :: tl - integer , intent(in) :: nets - integer , intent(in) :: nete - - ! Local - integer :: ie,nm1,n0,np1,k,qn0,qnp1,m_cnst, nq,p - real(kind=r8) :: eta_dot_dpdn(np,np,nlev+1) - - - call t_startf('prim_advance_exp') - nm1 = tl%nm1 - n0 = tl%n0 - np1 = tl%np1 - - !!jt ie needs to be set correctly for IOP's and CAMIOP's - ie=35 - call TimeLevel_Qdp(tl, qsplit, qn0, qnp1) ! compute current Qdp() timelevel - - do k=1,nlev - eta_dot_dpdn(:,:,k)=elem(ie)%derived%omega(:,:,k) - enddo - eta_dot_dpdn(:,:,nlev+1) = eta_dot_dpdn(:,:,nlev) - - do k=1,nlev - elem(ie)%state%dp3d(:,:,k,np1) = elem(ie)%state%dp3d(:,:,k,n0) & - + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) - enddo - - do k=1,nlev - elem(ie)%state%T(:,:,k,np1) = elem(ie)%state%T(:,:,k,n0) - enddo - - do p=1,qsize - do k=1,nlev - elem(ie)%state%Qdp(:,:,k,p,qnp1) = elem(ie)%state%Qdp(:,:,k,p,qn0) & - + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + use control_mod, only: tstep_type, qsplit + use derivative_mod, only: derivative_t + use dimensions_mod, only: np, nlev + use element_mod, only: element_t + use hybvcoord_mod, only: hvcoord_t + use hybrid_mod, only: hybrid_t + use time_mod, only: TimeLevel_t, timelevel_qdp, tevolve + use fvm_control_volume_mod, only: fvm_struct + use cam_thermo, only: get_kappa_dry + use air_composition, only: thermodynamic_active_species_num + use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp + use physconst, only: cpair + implicit none + + type (element_t), intent(inout), target :: elem(:) + type(fvm_struct) , intent(inout) :: fvm(:) + type (derivative_t) , intent(in) :: deriv + type (hvcoord_t) :: hvcoord + type (hybrid_t) , intent(in) :: hybrid + real (kind=r8), intent(in) :: dt + type (TimeLevel_t) , intent(in) :: tl + integer , intent(in) :: nets + integer , intent(in) :: nete + + ! Local + integer :: ie,nm1,n0,np1,k,qn0,qnp1,m_cnst, nq,p + real(kind=r8) :: eta_dot_dpdn(np,np,nlev+1) + + + call t_startf('prim_advance_exp') + nm1 = tl%nm1 + n0 = tl%n0 + np1 = tl%np1 + + call TimeLevel_Qdp(tl, qsplit, qn0, qnp1) ! compute current Qdp() timelevel + + do ie=nets,nete + do k=1,nlev + eta_dot_dpdn(:,:,k)=elem(ie)%derived%omega(:,:,k) + enddo + eta_dot_dpdn(:,:,nlev+1) = eta_dot_dpdn(:,:,nlev) + + do k=1,nlev + elem(ie)%state%dp3d(:,:,k,np1) = elem(ie)%state%dp3d(:,:,k,n0) & + + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + enddo + + do k=1,nlev + elem(ie)%state%T(:,:,k,np1) = elem(ie)%state%T(:,:,k,n0) + enddo + + do p=1,qsize + do k=1,nlev + elem(ie)%state%Qdp(:,:,k,p,qnp1) = elem(ie)%state%Qdp(:,:,k,p,qn0) & + + elem(ie)%state%Qdp(:,:,k,p,qn0)/elem(ie)%state%dp3d(:,:,k,n0)*dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + enddo + enddo enddo - enddo - end subroutine set_prescribed_scm + end subroutine set_prescribed_scm end module prim_driver_mod diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 96c3febefe..7e4cd1d366 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -167,8 +167,8 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) integer ::nelemd_todo, np_todo logical ::scm_multcols = .false. logical ::iop_nudge_tq = .false. - real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update - real (r8), dimension(nlev) :: temp_tend, t_update, u_update, v_update + real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update, q_phys_frc + real (r8), dimension(nlev) :: t_phys_frc, t_update, u_update, v_update real (r8), dimension(nlev) :: t_in, u_in, v_in real (r8), dimension(nlev) :: relaxt, relaxq real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn @@ -186,58 +186,47 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) ii=3 jj=4 - ! Settings for traditional SCM run - nelemd_todo = 1 - np_todo = 1 - - if (scm_multcols) then - nelemd_todo = nelemd - np_todo = np - endif - - do k=1,nlev - p(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*elem(ie)%state%psdry(ii,jj) - dpscm(k) = elem(ie)%state%dp3d(ii,jj,k,tl_f) - end do - dt = get_step_size() ! Set initial profiles for current column do m=1,pcnst - stateQ_in(:nlev,m) = elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/dpscm(:nlev) + stateQ_in(:nlev,m) = elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/elem(ie)%state%dp3d(ii,jj,:nlev,tl_f) end do t_in(:nlev) = elem(ie)%state%T(ii,jj,:nlev,tl_f) u_in(:nlev) = elem(ie)%state%v(ii,jj,1,:nlev,tl_f) v_in(:nlev) = elem(ie)%state%v(ii,jj,2,:nlev,tl_f) - if (.not. use_3dfrc ) then - temp_tend(:) = 0.0_r8 - else - temp_tend(:) = elem(ie)%derived%fT(i,j,:) - endif +!!$ if (.not. use_3dfrc ) then +!!$ t_phys_frc(:) = 0.0_r8 +!!$ else + t_phys_frc(:) = elem(ie)%derived%fT(ii,jj,:) + q_phys_frc(:,:) = elem(ie)%derived%fQ(ii,jj,:,:)/dt +!!$ endif ! Call the main subroutine to update t, q, u, and v according to ! large scale forcing as specified in IOP file. call advance_iop_forcing(dt,elem(ie)%state%psdry(ii,jj),& ! In - u_in,v_in,t_in,stateQ_in,temp_tend, hvcoord, & ! In + u_in,v_in,t_in,stateQ_in,t_phys_frc, q_phys_frc, hvcoord, & ! In u_update,v_update,t_update,q_update) ! Out ! Nudge to observations if desired, for T & Q only if in SCM mode - if (iop_nudge_tq .and. .not. scm_multcols) then + if (iop_nudge_tq ) then call advance_iop_nudging(dt,elem(ie)%state%psdry(ii,jj),& ! In t_update,q_update(:,1), hvcoord, & ! Inn t_update,q_update(:,1),relaxt,relaxq) ! Out endif - - ! Update the q related arrays. NOTE that Qdp array must - ! be updated first to ensure exact restarts + + if (use_3dfrc) then ! vertical remap of dynamics not run need to update state%dp3d using new psdry + do k=1,nlev + elem(ie)%state%dp3d(ii,jj,k,tl_f) = (hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + (hvcoord%hybi(k+1)-hvcoord%hybi(k))*elem(ie)%state%psdry(ii,jj) + end do + end if + + ! Update qdp using new dp3d do m=1,pcnst ! Update the Qdp array elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp) = & - q_update(:nlev,m) * dpscm(:nlev) - ! Update the Q array -!jt elem(ie)%state%Q(ii,jj,:nlev,m) = & -!jt elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/dpscm(:nlev) + q_update(:nlev,m) * elem(ie)%state%dp3d(ii,jj,:nlev,tl_f) enddo ! Update prognostic variables to the current values @@ -253,21 +242,8 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) end do ! Add various diganostic outfld calls - - if (scm_multcols) then - do i=1,np - do j=1,np - tdiff_out(i+(j-1)*np,:)=tdiff_dyn(:) - qdiff_out(i+(j-1)*np,:)=qdiff_dyn(:) - end do - end do - call outfld('TDIFF',tdiff_out,npsq,ie) - call outfld('QDIFF',qdiff_out,npsq,ie) - else - call outfld('TDIFF',tdiff_dyn,1,begchunk) - call outfld('QDIFF',qdiff_dyn,1,begchunk) - endif - + call outfld('TDIFF',tdiff_dyn,1,begchunk) + call outfld('QDIFF',qdiff_dyn,1,begchunk) call outfld('TOBS',tobs,1,begchunk) call outfld('QOBS',qobs,1,begchunk) call outfld('DIVQ',divq,1,begchunk) diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index 75b3b62018..24da1e222f 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -260,7 +260,10 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) integer :: rc, i, j, k, p, ie #if defined (BFB_CAM_SCAM_IOP) real(r8) :: forcing_temp(npsq,nlev), forcing_q(npsq,nlev,pcnst) - real(r8) :: ftmp_temp(np,np,nlev,nelemd), ftmp_q(np,np,nlev,pcnst,nelemd) + real(r8) :: ftmp_temp(np,np,nlev,nelemd), ftmp_q(np,np,nlev,pcnst,nelemd), & + ftmp_fq(np,np,nlev,pcnst,nelemd), ftmp_q_update(np,np,nlev,pcnst,nelemd), & + ftmp_q_diff(np,np,nlev,pcnst,nelemd),ftmp_newqdp_diff(np,np,nlev,pcnst,nelemd), & + ftmp_t_update(np,np,nlev,nelemd),ftmp_newt_diff(np,np,nlev,nelemd) real(r8) :: out_temp(npsq,nlev), out_q(npsq,nlev), out_u(npsq,nlev), & out_v(npsq,nlev), out_psv(npsq) #endif @@ -278,6 +281,7 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) do ie=1,nelemd ftmp_temp(:,:,:,ie) = dyn_in%elem(ie)%state%T(:,:,:,tl_f) do p = 1, qsize_d + ftmp_fq(:,:,:,p,ie)=dyn_in%elem(ie)%derived%FQ(:,:,:,p)/dtime ftmp_q(:,:,:,p,ie) = dyn_in%elem(ie)%state%Qdp(:,:,:,p,tl_fQdp)/& dyn_in%elem(ie)%state%dp3d(:,:,:,tl_f) enddo @@ -288,8 +292,7 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) ! Update IOP properties e.g. omega, divT, divQ - if (.not. is_first_step()) iop_update_phase1 = .false. -!jt e3sm has this iop_update_phase1 = .false. + iop_update_phase1 = .false. if (doiopupdate) then call scm_setinitial(dyn_out%elem) if (masterproc) call readiopdata(iop_update_phase1,hvcoord) @@ -337,12 +340,20 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) out_psv(i+(j-1)*np) = dyn_in%elem(ie)%state%psdry(i,j) + ftmp_t_update(i,j,k,ie) = ftmp_temp(i,j,k,ie) + dtime*(dyn_in%elem(ie)%derived%FT(i,j,k) + forcing_temp(i+(j-1)*np,k)) + ftmp_newt_diff(i,j,k,ie) = dyn_in%elem(ie)%state%T(i,j,k,tl_f)-ftmp_t_update(i,j,k,ie) + dyn_in%elem(ie)%state%T(i,j,k,tl_f)=ftmp_t_update(i,j,k,ie) + out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) do p=1,qsize_d forcing_q(i+(j-1)*np,k,p) = (dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)/& dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - & - ftmp_q(i,j,k,p,ie))/dtime + ftmp_q(i,j,k,p,ie))/dtime - ftmp_fq(i,j,k,p,ie) + ftmp_q_update(i,j,k,p,ie) = ftmp_q(i,j,k,p,ie) + dtime*(ftmp_fq(i,j,k,p,ie) + forcing_q(i+(j-1)*np,k,p)) + ftmp_newqdp_diff(i,j,k,p,ie)=dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)-(ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f)) + dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)=ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) enddo - + out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) enddo enddo enddo From fd265ed20d1b95b1087e972dad9ab84d6fbdd3d3 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 29 Sep 2023 14:32:51 -0600 Subject: [PATCH 04/75] se scm updates to cmeps cdeps externals --- Externals.cfg | 20 ++++++++++---------- bld/configure | 2 +- bld/namelist_files/namelist_defaults_cam.xml | 12 ------------ cime_config/config_compsets.xml | 2 +- 4 files changed, 12 insertions(+), 24 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 9badad437d..13f03b95bd 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,7 +1,7 @@ [ccs_config] -tag = ccs_config_cesm0.0.73 +branch = ccs_config_cesm_scamdev protocol = git -repo_url = https://github.com/ESMCI/ccs_config_cesm +repo_url = https://github.com/jtruesdal/ccs_config_cesm local_path = ccs_config required = True @@ -13,24 +13,24 @@ local_path = components/cice5 required = True [cice6] -tag = cesm_cice6_4_1_8 +tag = cesm_cice6_4_1_8_scamdev protocol = git -repo_url = https://github.com/ESCOMP/CESM_CICE +repo_url = https://github.com/jtruesdal/CESM_CICE local_path = components/cice externals = Externals.cfg required = True [cmeps] -tag = cmeps0.14.34 +branch = cmeps0.14.34_scamdev protocol = git -repo_url = https://github.com/ESCOMP/CMEPS.git +repo_url = https://github.com/jtruesdal/CMEPS.git local_path = components/cmeps required = True [cdeps] -tag = cdeps1.0.14 +branch = cdeps1.0.14_scamdev protocol = git -repo_url = https://github.com/ESCOMP/CDEPS.git +repo_url = https://github.com/jtruesdal/CDEPS.git local_path = components/cdeps externals = Externals_CDEPS.cfg required = True @@ -79,9 +79,9 @@ externals = Externals_CISM.cfg required = True [clm] -tag = ctsm5.1.dev124 +tag = ctsm5.1.dev124_scamdev protocol = git -repo_url = https://github.com/ESCOMP/CTSM +repo_url = https://github.com/jtruesdal/ctsm local_path = components/clm externals = Externals_CLM.cfg required = True diff --git a/bld/configure b/bld/configure index 4f047b9baa..062bc33cf4 100755 --- a/bld/configure +++ b/bld/configure @@ -1190,7 +1190,7 @@ if (defined $opts{'scam'}) { } my $scam = $cfg_ref->get('scam') ? "ON" : "OFF"; -# The only dycore supported in SCAM mode is Eulerian +# The only dycores supported in SCAM mode are Eulerian and Spectral Elements if ($scam eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) { die <<"EOF"; ** ERROR: SCAM mode only works with Eulerian dycore. diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index c1c27c7370..7af897665c 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -313,11 +313,7 @@ atm/cam/topo/se/ne60pg2_nc3000_Co030_Fi001_PF_nullRR_Nsw021_20171014.nc atm/cam/topo/se/ne120pg2_nc3000_Co015_Fi001_PF_nullRR_Nsw010_20171012.nc atm/cam/topo/se/ne240pg2_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171014.nc - -<<<<<<< HEAD atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc -======= ->>>>>>> cam_development atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc @@ -1898,20 +1894,12 @@ OFF -<<<<<<< HEAD atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_221214.nc atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne16pg3_230520.nc -======= -atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_c221214.nc -atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc -atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc -atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc -atm/cam/chem/trop_mam/atmsrf_ne16pg3_c230520.nc ->>>>>>> cam_development atm/cam/chem/trop_mam/atmsrf_ne30np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne30np4.pg2_200108.nc atm/cam/chem/trop_mam/atmsrf_ne30pg3_180522.nc diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 249395a05a..eedcf65e38 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -123,7 +123,7 @@ FSCAM 2000_CAM60%SCAM_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - + From f202756e1a30b4c705742021db6ff6341725c5a1 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 26 Nov 2023 10:12:54 -0700 Subject: [PATCH 05/75] scam updates --- bld/namelist_files/namelist_defaults_cam.xml | 7 +- src/control/scamMod.F90 | 28 +- src/dynamics/eul/dp_coupling.F90 | 2 +- src/dynamics/eul/dyn_comp.F90 | 25 +- src/dynamics/eul/dyn_grid.F90 | 125 +- src/dynamics/eul/iop.F90 | 35 +- src/dynamics/eul/scmforecast.F90 | 34 +- src/dynamics/eul/stepon.F90 | 18 +- src/dynamics/se/apply_iop_forcing.F90 | 172 +- src/dynamics/se/dycore/prim_driver_mod.F90 | 11 +- src/dynamics/se/dyn_comp.F90 | 34 +- src/dynamics/se/se_single_column_mod.F90 | 300 +- src/dynamics/se/stepon.F90 | 21 +- src/infrastructure/phys_grid.F90 | 24 +- src/physics/cam/check_energy.F90 | 22 +- src/physics/cam/chem_surfvals.F90 | 4 +- src/physics/cam/phys_grid.F90 | 5742 ++++++++++++++---- src/physics/cam/physpkg.F90 | 2440 ++++---- 18 files changed, 6579 insertions(+), 2465 deletions(-) diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 7af897665c..feb4764e25 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -315,6 +315,7 @@ atm/cam/topo/se/ne240pg2_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171014.nc atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc +atm/cam/topo/USGS-gtopo30_ne4np4_16x.c20160612.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_20230105.nc @@ -1896,6 +1897,7 @@ atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_221214.nc +atm/cam/chem/trop_mam/atmsrf_ne4np4_from_0.23x0.31_181018.nc atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc @@ -2851,7 +2853,10 @@ 1500 9 .true. - slt + slt + +atm/cam/inic/homme/cami_mam3_Linoz_ne4np4_L72_c160909.nc +atm/cam/scam/iop/TOGAII_4scam.nc diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index 02b188b2bb..2ae0c18b04 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -391,7 +391,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) end subroutine scam_readnl -subroutine readiopdata(iop_update_phase1, hvcoord) +subroutine readiopdata(hvcoord) !jt subroutine readiopdata(timelevel) @@ -425,7 +425,6 @@ subroutine readiopdata(iop_update_phase1, hvcoord) !------------------------------Input Arguments-------------------------- ! !jt integer, optional, intent(in) :: timelevel -logical, intent(in) :: iop_update_phase1 type (hvcoord_t), intent(in) :: hvcoord !------------------------------Locals----------------------------------- @@ -727,7 +726,8 @@ subroutine readiopdata(iop_update_phase1, hvcoord) ! with capital T defined in cam ! -!!$ tobs(:)= t3(1,:,1,ntimelevel) +!jt tobs(:)= t3(1,:,1,ntimelevel) + tobs(:)= 0._r8 if ( use_camiop ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'t', have_tsair, & @@ -782,11 +782,12 @@ subroutine readiopdata(iop_update_phase1, hvcoord) have_srf = .true. endif -!!$ if (is_first_step()) then -!!$ qinitobs(:,:)=q3(1,:,:,1,ntimelevel) -!!$ end if +!jt if (is_first_step()) then +!jt qinitobs(:,:)=q3(1,:,:,1,ntimelevel) +!jt end if !!$ -!!$ qobs(:)= q3(1,:,1,1,ntimelevel) +!jt qobs(:)= q3(1,:,1,1,ntimelevel) + qobs(:)= 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & srf(1), fill_ends, scm_crm_mode, & @@ -1076,11 +1077,18 @@ subroutine readiopdata(iop_update_phase1, hvcoord) vertdivt=0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivTx', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) if ( status .ne. nf90_noerr ) then - have_vertdivt = .false. + call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & + have_srf, srf(1), fill_ends, scm_crm_mode, & + dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) + if ( status .ne. nf90_noerr ) then + have_vertdivt = .false. + else + have_vertdivt = .true. + endif else have_vertdivt = .true. endif @@ -1320,7 +1328,7 @@ subroutine readiopdata(iop_update_phase1, hvcoord) ! make sure that use_3dfrc flag is set to true if we only have ! 3d forcing available ! - if (scm_use_3dfrc .and. (have_divt3d .or. have_divq3d)) then + if (scm_use_3dfrc .and. (have_divt3d .and. have_divq3d)) then use_3dfrc = .true. else use_3dfrc = .false. diff --git a/src/dynamics/eul/dp_coupling.F90 b/src/dynamics/eul/dp_coupling.F90 index bc900e2d0e..0503b33ccc 100644 --- a/src/dynamics/eul/dp_coupling.F90 +++ b/src/dynamics/eul/dp_coupling.F90 @@ -5,7 +5,7 @@ module dp_coupling use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver + use ppgrid, only: pcols, pver, begchunk, endchunk use pmgrid, only: plev, beglat, endlat, plon use phys_grid diff --git a/src/dynamics/eul/dyn_comp.F90 b/src/dynamics/eul/dyn_comp.F90 index 442c9f3228..2f5b36931d 100644 --- a/src/dynamics/eul/dyn_comp.F90 +++ b/src/dynamics/eul/dyn_comp.F90 @@ -32,7 +32,7 @@ module dyn_comp use scamMod, only: single_column, use_camiop, have_u, have_v, & have_cldliq, have_cldice, loniop, latiop, scmlat, scmlon, & - qobs,tobs,scm_cambfb_mode + qobs,tobs,scm_cambfb_mode,uobs,vobs,psobs use cam_pio_utils, only: clean_iodesc_list, cam_pio_get_var use pio, only: file_desc_t, pio_noerr, pio_inq_varid, pio_get_att, & @@ -367,8 +367,9 @@ subroutine read_inidat() use ncdio_atm, only: infld - use iop, only: setiopupdate,readiopdata - + use scamMod, only: setiopupdate,setiopupdate_init,readiopdata + use dyn_grid, only: hvcoord + use iop, only: iop_update_prognostics ! Local variables integer i,c,m,n,lat ! indices @@ -403,6 +404,7 @@ subroutine read_inidat() real(r8), allocatable :: tmp2d(:,:) character(len=*), parameter :: sub='read_inidat' + integer ioptop,k !---------------------------------------------------------------------------- fh_ini => initial_file_get_id() @@ -581,12 +583,19 @@ subroutine read_inidat() latiop(2)=(scmlat+2._r8)*pi/180_r8 loniop(1)=(mod(scmlon-2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8 loniop(2)=(mod(scmlon+2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8 + call setiopupdate_init() call setiopupdate() - ! readiopdata will set all n1 level prognostics to iop value timestep 0 - call readiopdata(timelevel=1) - ! set t3, and q3(n1) values from iop on timestep 0 - t3(1,:,1,1) = tobs - q3(1,:,1,1,1) = qobs + call readiopdata(hvcoord) + call iop_update_prognostics(1,t3=t3,u3=u3,v3=v3,q3=q3,ps=ps) +!!$ ! set t3, and q3(n1) values from iop on timestep 0 +!!$ ! Find level where tobs is no longer zero +!!$ ioptop = minloc(tobs(:), 1, BACK=.true.)+1 +!!$ +!!$ ps(:,:,1) = psobs +!!$ t3(1,ioptop:,1,1) = tobs(ioptop:) +!!$ u3(1,ioptop:,1,1) = uobs(ioptop:) +!!$ v3(1,ioptop:,1,1) = vobs(ioptop:) +!!$ q3(1,ioptop:,1,1,1) = qobs(ioptop:) end if end if diff --git a/src/dynamics/eul/dyn_grid.F90 b/src/dynamics/eul/dyn_grid.F90 index e8cd67b0a0..1b2ecf3646 100644 --- a/src/dynamics/eul/dyn_grid.F90 +++ b/src/dynamics/eul/dyn_grid.F90 @@ -17,6 +17,10 @@ module dyn_grid use cam_abortutils, only: endrun use cam_logfile, only: iulog +use hybvcoord_mod, only: hvcoord_t +use shr_const_mod, only: SHR_CONST_PI, SHR_CONST_REARTH +use physics_column_type, only: physics_column_t + #if (defined SPMD) use spmd_dyn, only: spmdinit_dyn @@ -47,6 +51,8 @@ module dyn_grid ! from a given global column index get_horiz_grid_d, &! horizontal grid coordinates get_horiz_grid_dim_d, &! horizontal dimensions of dynamics grid + hvcoord, &! vertical coordinate parameters + get_dyn_grid_info, &! Return dynamics grid column information physgrid_copy_attributes_d ! The Eulerian dynamics grids @@ -54,8 +60,14 @@ module dyn_grid integer, parameter, public :: ptimelevels = 3 ! number of time levels in the dycore +real(r8), parameter :: rad2deg = 180._r8/SHR_CONST_PI + integer :: ngcols_d = 0 ! number of dynamics columns +type (hvcoord_t) :: hvcoord + +type(physics_column_t), allocatable, target :: local_dyn_columns(:) + !======================================================================================== contains !======================================================================================== @@ -73,7 +85,7 @@ subroutine dyn_grid_init latdeg, londeg, xm use time_manager, only: get_step_size use scamMod, only: scmlat, scmlon, single_column - use hycoef, only: hycoef_init, hypi, hypm, hypd, nprlev + use hycoef, only: hycoef_init, hypi, hypm, hypd, nprlev, hyam,hybm,hyai,hybi,ps0 use ref_pres, only: ref_pres_init use eul_control_mod, only: ifax, trig, eul_nsplit @@ -124,6 +136,15 @@ subroutine dyn_grid_init ! Initialize hybrid coordinate arrays call hycoef_init(fh_ini) + hvcoord%hyam = hyam + hvcoord%hyai = hyai + hvcoord%hybm = hybm + hvcoord%hybi = hybi + hvcoord%ps0 = ps0 + do k = 1, plev + hvcoord%hybd(k) = hvcoord%hybi(k+1) - hvcoord%hybi(k) + end do + ! Initialize reference pressures call ref_pres_init(hypi, hypm, nprlev) @@ -863,7 +884,6 @@ end function get_dyn_grid_parm !------------------------------------------------------------------------------- subroutine dyn_grid_find_gcols( lat, lon, nclosest, owners, indx, jndx, rlat, rlon, idyn_dists ) use spmd_utils, only: iam - use shr_const_mod, only: SHR_CONST_PI, SHR_CONST_REARTH use pmgrid, only: plon, plat real(r8), intent(in) :: lat @@ -886,7 +906,6 @@ subroutine dyn_grid_find_gcols( lat, lon, nclosest, owners, indx, jndx, rlat, rl real(r8), allocatable :: clat_d(:), clon_d(:), distmin(:) integer, allocatable :: igcol(:) - real(r8), parameter :: rad2deg = 180._r8/SHR_CONST_PI latr = lat/rad2deg lonr = lon/rad2deg @@ -1193,6 +1212,106 @@ subroutine define_cam_grids() end subroutine define_cam_grids +!============================================================================== + +subroutine get_dyn_grid_info(hdim1_d, hdim2_d, num_lev, & + index_model_top_layer, index_surface_layer, unstructured, dyn_columns) + !------------------------------------------------------------ + ! + ! get_dyn_grid_info returns physics grid column information + ! + !------------------------------------------------------------ + use cam_abortutils, only: endrun + use spmd_utils, only: iam + use commap, only: londeg, latdeg, w + use pmgrid, only: beglat, endlat, plon, plat + ! Dummy arguments + integer, intent(out) :: hdim1_d ! # longitudes or grid size + integer, intent(out) :: hdim2_d ! # latitudes or 1 + integer, intent(out) :: num_lev ! # levels + integer, intent(out) :: index_model_top_layer + integer, intent(out) :: index_surface_layer + logical, intent(out) :: unstructured + ! dyn_columns will contain a copy of the physics column info local to this + ! dynamics task + type(physics_column_t), allocatable, intent(out) :: dyn_columns(:) + ! Local variables + integer :: blockid(1), bcid(1) + integer :: lindex + integer :: gindex + integer :: num_local_cols + integer :: ncol + integer :: ngcols + integer :: owner + integer :: indx + integer :: jndx + real(r8), allocatable :: clat_d(:), clon_d(:), area_d(:), wght_d(:) + real(r8), parameter :: radtodeg = 180.0_r8 / SHR_CONST_PI + real(r8), parameter :: degtorad = SHR_CONST_PI / 180.0_r8 + character(len=*), parameter :: subname = 'get_dyn_grid_info' + + unstructured = .false. ! EUL is an structured dycore + num_local_cols = plon*(endlat-beglat+1) + if (allocated(local_dyn_columns)) then + ! Check for correct number of columns + if (size(local_dyn_columns) /= num_local_cols) then + call endrun(subname//': called with inconsistent column numbers') + end if + else + allocate(local_dyn_columns(num_local_cols)) + end if + hdim1_d = plon + hdim2_d = plat + num_lev = plev + index_model_top_layer = 1 + index_surface_layer = plev + ngcols = plon*plat + allocate( clat_d(1:ngcols) ) + allocate( clon_d(1:ngcols) ) + allocate( area_d(1:ngcols) ) + allocate( wght_d(1:ngcols) ) + call get_horiz_grid_d(ngcols, clat_d_out=clat_d, clon_d_out=clon_d, area_d_out=area_d, wght_d_out=wght_d) + ncol = 0 + do gindex = 1,ngcols + call get_gcol_block_d( gindex, 1, blockid, bcid ) + owner = get_block_owner_d(blockid(1)) + if ( iam==owner ) then + ncol=ncol+1 + lindex = bcid(1) + local_dyn_columns(lindex)%lat_rad = clat_d(gindex) + local_dyn_columns(lindex)%lon_rad = clon_d(gindex) + local_dyn_columns(lindex)%lat_deg = clat_d(gindex) * rad2deg + local_dyn_columns(lindex)%lon_deg = clon_d(gindex) * rad2deg + local_dyn_columns(lindex)%lon_deg = area_d(gindex) + local_dyn_columns(lindex)%lon_deg = wght_d(gindex) + local_dyn_columns(lindex)%global_col_num = gindex + local_dyn_columns(lindex)%dyn_task = iam + local_dyn_columns(lindex)%local_dyn_block = blockid(1)-beglat+1 + local_dyn_columns(lindex)%global_dyn_block = blockid(1) + ! get global lat and lon coordinate indices from global column index + ! -- plon is global number of longitude grid points + jndx = (gindex-1)/plon + 1 + indx = gindex - (jndx-1)*plon + local_dyn_columns(lindex)%coord_indices(1)=indx + local_dyn_columns(lindex)%coord_indices(2)=jndx + end if + end do + ! Copy the information to the output array + if (allocated(dyn_columns)) then + deallocate(dyn_columns) + end if + allocate(dyn_columns(ncol)) + do lindex = 1, ncol + dyn_columns(lindex) = local_dyn_columns(lindex) + end do + + deallocate( clat_d ) + deallocate( clon_d ) + deallocate( area_d ) + deallocate( wght_d ) + + end subroutine get_dyn_grid_info + !======================================================================================== end module dyn_grid diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90 index 79b7334dcc..55cc4fad37 100644 --- a/src/dynamics/eul/iop.F90 +++ b/src/dynamics/eul/iop.F90 @@ -38,7 +38,7 @@ module iop ! ! !PUBLIC MEMBER FUNCTIONS: public :: init_iop_fields -! public :: scam_use_iop_srf + public :: iop_update_prognostics ! !PUBLIC DATA: public betasav, & dqfx3sav, divq3dsav, divt3dsav,divu3dsav,divv3dsav,t2sav,fusav,fvsav @@ -104,6 +104,39 @@ subroutine init_iop_fields() endif end subroutine init_iop_fields + subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3) +!------------------------------------------------------------------------------ +! Copy IOP forcing fields into prognostics which for Eulerian is just PS +!------------------------------------------------------------------------------ + use scamMod, only: tobs,uobs,vobs,qobs,psobs + use prognostics, only: ptimelevels + implicit none + + !----------------------------------------------------------------------- + + integer, intent(in) :: timelevel + real(r8), optional, intent(inout) :: q3(:,:,:,:,:) + real(r8), optional, intent(inout) :: u3(:,:,:,:) + real(r8), optional, intent(inout) :: v3(:,:,:,:) + real(r8), optional, intent(inout) :: t3(:,:,:,:) +! real(r8), optional, intent(inout) :: ps(plon,beglat:endlat,ptimelevels) + real(r8), optional, intent(inout) :: ps(:,:,:) + +!---------------------------Local workspace----------------------------- + integer :: ioptop + character(len=*), parameter :: sub = "iop_update_prognostics" +!----------------------------------------------------------------------- + ! set prognostics from iop + ! Find level where tobs is no longer zero + ioptop = minloc(tobs(:), 1, BACK=.true.)+1 + + if (present(ps)) ps(1,1,timelevel) = psobs + if (present(t3)) t3(1,ioptop:,1,timelevel) = tobs(ioptop:) + if (present(u3)) u3(1,ioptop:,1,timelevel) = uobs(ioptop:) + if (present(v3)) v3(1,ioptop:,1,timelevel) = vobs(ioptop:) + if (present(q3)) q3(1,ioptop:,1,1,timelevel) = qobs(ioptop:) + + end subroutine iop_update_prognostics end module iop diff --git a/src/dynamics/eul/scmforecast.F90 b/src/dynamics/eul/scmforecast.F90 index f9c0cbc6a8..1489a50ef5 100644 --- a/src/dynamics/eul/scmforecast.F90 +++ b/src/dynamics/eul/scmforecast.F90 @@ -116,7 +116,7 @@ subroutine forecast( lat , nlon , ztodt , & integer dummy integer dummy_dyndecomp integer i, k, m - integer ixcldliq, ixcldice, ixnumliq, ixnumice + integer ixcldliq, ixcldice, ixnumliq, ixnumice, ioptop real(r8) weight, fac real(r8) pmidm1(plev) real(r8) pintm1(plevp) @@ -222,6 +222,7 @@ subroutine forecast( lat , nlon , ztodt , & dummy = 2 dummy_dyndecomp = 1 + ioptop = minloc(tobs(:), 1, BACK=.true.)+1 ! ------------------------------------------------------------ ! @@ -461,10 +462,12 @@ subroutine forecast( lat , nlon , ztodt , & endif if( scm_use_obs_uv .and. have_u .and. have_v ) then - do k = 1, plev - ufcst(k) = uobs(k) - vfcst(k) = vobs(k) - enddo + ufcst=u3 + vfcst=v3 + ufcst(ioptop:plev)=uobs(ioptop:plev) + vfcst(ioptop:plev)=vobs(ioptop:plev) + ufcst(:plev)=uobs(:plev) + vfcst(:plev)=vobs(:plev) endif if( scm_use_obs_qv .and. have_q ) then @@ -544,17 +547,26 @@ subroutine forecast( lat , nlon , ztodt , & ! --------------------------------------------------------- ! ! Assign the final forecasted state to the output variables ! ! --------------------------------------------------------- ! + + !Fill out tobs/qobs with background CAM state above IOP top before t3 update below + tobs(1:ioptop-1)=t3(1:ioptop-1) + qobs(1:ioptop-1)=q3(1:ioptop-1,1) + + t3(:plev)=tfcst(:plev) + u3(:plev)=ufcst(:plev) + v3(:plev)=vfcst(:plev) + q3(:plev,:pcnst)=qfcst(1,:plev,:pcnst) - t3(1:plev) = tfcst(1:plev) - u3(1:plev) = ufcst(1:plev) - v3(1:plev) = vfcst(1:plev) - q3(1:plev,1:pcnst) = qfcst(1,1:plev,1:pcnst) +!!$ t3(1:plev) = tfcst(1:plev) +!!$ u3(1:plev) = ufcst(1:plev) +!!$ v3(1:plev) = vfcst(1:plev) +!!$ q3(1:plev,1:pcnst) = qfcst(1,1:plev,1:pcnst) tdiff(1:plev) = t3(1:plev) - tobs(1:plev) qdiff(1:plev) = q3(1:plev,1) - qobs(1:plev) - call outfld( 'QDIFF' , qdiff, plon, dummy_dyndecomp ) - call outfld( 'TDIFF' , tdiff, plon, dummy_dyndecomp ) + call outfld( 'QDIFF' , qdiff, plon, dummy ) + call outfld( 'TDIFF' , tdiff, plon, dummy ) return diff --git a/src/dynamics/eul/stepon.F90 b/src/dynamics/eul/stepon.F90 index 61c3eea1ce..02e7064fb3 100644 --- a/src/dynamics/eul/stepon.F90 +++ b/src/dynamics/eul/stepon.F90 @@ -16,14 +16,14 @@ module stepon use ppgrid, only: begchunk, endchunk use physics_types, only: physics_state, physics_tend use time_manager, only: is_first_step, get_step_size - use iop, only: setiopupdate, readiopdata - use scamMod, only: use_iop,doiopupdate,use_pert_frc,wfld,wfldh,single_column + use scamMod, only: use_iop,doiopupdate,use_pert_frc,wfld,wfldh,single_column,setiopupdate, readiopdata use perf_mod use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state use microp_aero, only: aerosol_state_object, aerosol_properties_object - + use dyn_grid, only: hvcoord + implicit none private save @@ -294,6 +294,9 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) !----------------------------------------------------------------------- use dyn_comp, only: dyn_import_t, dyn_export_t use eul_control_mod,only: eul_nsplit + use prognostics, only: ps + use iop, only: iop_update_prognostics + real(r8), intent(in) :: ztodt ! twice time step unless nstep=0 type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) type(physics_state), intent(in):: phys_state(begchunk:endchunk) @@ -309,10 +312,13 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) call setiopupdate end if - ! Update IOP properties e.g. omega, divT, divQ - - if (doiopupdate) call readiopdata() + ! Read IOP data and update prognostics if needed + if (doiopupdate) then + call readiopdata(hvcoord) +!jt call iop_update_prognostics(n3,ps=ps(:,:,:)) + call iop_update_prognostics(n3,ps=ps) + end if endif !---------------------------------------------------------- diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index 047e1779ad..92637be444 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -1,15 +1,14 @@ module apply_iop_forcing_mod -use shr_kind_mod, only: r8 => shr_kind_r8, i8 => shr_kind_i8 +use shr_kind_mod, only:r8 => shr_kind_r8, i8 => shr_kind_i8 use pmgrid -use constituents, only: pcnst, cnst_get_ind -use physconst, only: rair,cpair -use cam_logfile, only: iulog -use hybvcoord_mod, only : hvcoord_t -!use camiop, only: use_3dfrc, single_column, have_u, have_v, divT3d, divq3d, divt, divq, & -! wfld, uobs, vobs, tobs, qobs +use constituents, only:pcnst, cnst_get_ind +use physconst, only:rair,cpair +use cam_logfile, only:iulog +use hybvcoord_mod, only: hvcoord_t use scamMod, only: use_3dfrc, single_column, have_u, have_v, divT3d, divq3d, divt, divq, & - wfld, uobs, vobs, tobs, qobs, plevs0 + wfld, uobs, vobs, tobs, qobs, plevs0, have_divt3d, have_divq3d +use cam_abortutils, only: endrun implicit none public advance_iop_forcing @@ -19,6 +18,125 @@ module apply_iop_forcing_mod contains !========================================================================= +!$$subroutine advance_iop_forcing(scm_dt ,hvcoord ,psm1 , & ! In +!$$ u3m1 ,u3m2 ,u_phys_frc , & ! In +!$$ v3m1 ,v3m2 ,v_phys_frc , & ! In +!$$ t3m1 ,t3m2 ,t_phys_frc , & ! In +!$$ q3m1 ,q3m2 ,q_phys_frc , & ! In +!$$ u3 ,v3 ,t3 , & ! Out +!$$ q3 ) ! Out +!$$!----------------------------------------------------------------------- +!$$! +!$$! Purpose: +!$$! --------------------------------------------------------------------------- ! +!$$! ! +!$$! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', ! +!$$! 'horizontal advection', and 'vertical advection' tendencies. ! +!$$! This module is used only for SCAM. ! +!$$! ! +!$$! --------------------------------------------------------------------------- ! +!$$! +!$$! Author: +!$$! Original version: Adopted from CAM3.5/CAM5 +!$$! Substantially refactored by Sung Su Park +!$$! Updated for SE dycore: Peter Bogenschutz (bogenschutz1@llnl.gov) John Truesdale (jet.ucar.edu) +!$$! +!$$! --------------------------------------------------- +!$$! x = t, u, v, q +!$$! x3m1 : state variable used for computing 'forcing' +!$$! x3m2 : initial state variable before time-marching +!$$! x3 : final state variable after time-marching +!$$!----------------------------------------------------------------------- +!$$ +!$$! Input arguments +!$$ real(r8), intent(in) :: scm_dt ! model time step [s] +!$$ type (hvcoord_t), intent(in) :: hvcoord +!$$ real(r8), intent(in) :: psm1 ! surface pressure [Pa] +!$$ real(r8), intent(in) :: u3m1(plev) ! Zonal wind [ m/s ] +!$$ real(r8), intent(in) :: u3m2(plev) ! Zonal wind [ m/s ] +!$$ real(r8), intent(in) :: u_phys_frc(plev) ! Zonal wind [ m/s ] +!$$ real(r8), intent(in) :: v3m1(plev) ! Meridional wind [ m/s ] +!$$ real(r8), intent(in) :: v3m2(plev) ! Meridional wind [ m/s ] +!$$ real(r8), intent(in) :: v_phys_frc(plev) ! Meridional wind [ m/s ] +!$$ real(r8), intent(in) :: t3m1(plev) ! temperature [K] +!$$ real(r8), intent(in) :: t3m2(plev) ! temperature [K] +!$$ real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] +!$$ real(r8), intent(in) :: q3m1(plev,pcnst) ! Meridional wind [ m/s ] +!$$ real(r8), intent(in) :: q3m2(plev,pcnst) ! Meridional wind [ m/s ] +!$$ real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! temperature forcing from physics [K/s] +!$$ +!$$ ! Output arguments +!$$ real(r8), intent(out) :: t3(plev) ! updated temperature [K] +!$$ real(r8), intent(out) :: q3(plev,pcnst)! updated q tracer array [units vary] +!$$ real(r8), intent(out) :: u3(plev) ! updated zonal wind [m/s] +!$$ real(r8), intent(out) :: v3(plev) ! updated meridional wind [m/s] +!$$ +!$$ ! Local variables +!$$ real(r8) pmidm1(plev) ! pressure at model levels +!$$ real(r8) pintm1(plevp) ! pressure at model interfaces +!$$ real(r8) pdelm1(plev) ! pdel(k) = pint (k+1)-pint (k) +!$$ real(r8) t_lsf(plev) ! storage for temperature large scale forcing +!$$ real(r8) q_lsf(plev,pcnst) ! storage for moisture large scale forcing +!$$ real(r8) qten_phys(plev,pcnst) ! storage for moisture large scale forcing +!$$ real(r8) fac, t_expan +!$$ +!$$ integer i,k,m ! longitude, level, constituent indices +!$$ integer ixcldliq, ixcldice, ixnumliq, ixnumice +!$$ +!$$ ! Main Computation Begins Here ! +!$$ call cnst_get_ind( 'CLDLIQ', ixcldliq, abort=.false. ) +!$$ call cnst_get_ind( 'CLDICE', ixcldice, abort=.false. ) +!$$ call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) +!$$ call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) +!$$ +!$$ ! Calculate midpoint pressure levels ! +!$$ call plevs0(plev ,psm1 ,pintm1 ,pmidm1 ,pdelm1, hvcoord) +!$$ +!$$ +!$$ ! Extract physical tendencies of tracers q. +!$$ ! Note 'tten_phys, uten_phys, vten_phys' are already input. +!$$ qten_phys(:plev,:pcnst) = ( q_phys_frc(:plev,:pcnst) - q3m2(:plev,:pcnst) ) / scm_dt +!$$ +!$$ +!$$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$$ ! Advance T and Q due to large scale forcing +!$$ +!$$ if (use_3dfrc .or. have_divt3d) then +!$$ t_lsf(:plev) = divt3d(:plev) +!$$ q_lsf(:plev,:pcnst) = divq3d(:plev,:pcnst) +!$$ else +!$$ t_lsf(:plev) = divt(:plev) +!$$ q_lsf(:plev,:pcnst) = divq(:plev,:pcnst) +!$$ endif +!$$ +!$$ do k=1,plev +!$$ ! Initialize thermal expansion term to zero. This term is only +!$$ ! considered if using the preq-x dycore and if three dimensional +!$$ ! forcing is not provided by IOP forcing file. +!$$ t_expan = 0._r8 +!$$ +!$$!!$ if (.not. use_3dfrc) then +!$$!!$ t_expan = scm_dt*wfld(k)*t3m1(k)*rair/(cpair*pmidm1(k)) +!$$!!$ endif +!$$!!$ t_update(k) = t3m1(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) +!$$ t3(k) = t3m1(k) + scm_dt*(t_phys_frc(k) + t_lsf(k)) +!$$ do m=1,pcnst +!$$ q3(k,m) = scm_dt*(q_phys_frc(k,m) + q_lsf(k,m)) +!$$ end do +!$$ enddo +!$$ +!$$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!$$ ! Set U and V fields +!$$ +!$$ if ( have_v .and. have_u ) then +!$$ do k=1,plev +!$$ u3(k) = uobs(k) +!$$ v3(k) = vobs(k) +!$$ enddo +!$$ endif +!$$ +!$$end subroutine advance_iop_forcing +!$$ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In u_in, v_in, t_in, q_in, t_phys_frc, q_phys_frc, hvcoord, & ! In u_update, v_update, t_update, q_update) ! Out @@ -41,7 +159,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In real(r8), intent(in) :: u_in(plev) ! zonal wind [m/s] real(r8), intent(in) :: v_in(plev) ! meridional wind [m/s] real(r8), intent(in) :: t_in(plev) ! temperature [K] - real(r8), intent(in) :: q_in(plev,pcnst) ! q tracer array [units vary] + real(r8), intent(in) :: q_in(plev,pcnst) ! q tracer array [units vary] already vertically advected real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! temperature forcing from physics [K/s] type (hvcoord_t), intent(in) :: hvcoord @@ -64,6 +182,8 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In integer i,k,m ! longitude, level, constituent indices integer nlon + character(len=*), parameter :: subname = 'advance_iop_forcing' + !! Get vertical level profiles nlon = 1 ! number of columns for plevs0 routine @@ -73,6 +193,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In ! Advance T and Q due to large scale forcing if (use_3dfrc) then + if(.not.(have_divt3d.and.have_divq3d)) call endrun(subname//": FATAL: divt3d and divq3d not available") t_lsf(:plev) = divt3d(:plev) q_lsf(:plev,:pcnst) = divq3d(:plev,:pcnst) else @@ -81,21 +202,30 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In endif do k=1,plev - ! Initialize thermal expansion term to zero. This term is only - ! considered if using the preq-x dycore and if three dimensional - ! forcing is not provided by IOP forcing file. - t_expan = 0._r8 - + ! Initialize thermal expansion term to zero. This term is only + ! considered if three dimensional forcing is not provided by IOP forcing file. + t_expan = 0._r8 + if (.not. use_3dfrc) then t_expan = scm_dt*wfld(k)*t_in(k)*rair/(cpair*pmidm1(k)) endif - - t_update(k) = t_in(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) - do m=1,pcnst - q_update(k,m) = q_in(k,m) + scm_dt*(q_phys_frc(k,m) + q_lsf(k,m)) - end do - enddo - + + if (use_3dfrc) then + do m=1,pcnst + ! When using 3d dynamics tendencies, SCM skips the vertical advection step and thus + ! q_in at this point has not had physics tendencies applied + q_update(k,m) = q_in(k,m) + scm_dt*(q_phys_frc(k,m) + q_lsf(k,m)) + end do + t_update(k) = t_in(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) + else + do m=1,pcnst + ! When not using 3d dynamics tendencies, q_in at this point has had physics tend + ! applied and has been vertically advected. Only horizontal dyn tend needed for forecast. + q_update(k,m) = q_in(k,m) + scm_dt*q_lsf(k,m) + end do + t_update(k) = t_in(k) + t_expan + scm_dt*t_lsf(k) + end if + end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Set U and V fields diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index abd2eecfcc..57ecd67ff7 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -242,7 +242,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst real (kind=r8) , intent(inout):: omega_cn(2,nets:nete) !min and max of vertical Courant number real(kind=r8) :: dt_q, dt_remap, dt_phys - integer :: ie, q,k,n0_qdp,np1_qdp,r, nstep_end,region_num_threads,i,j,nets_in,nete_in + integer :: ie, q,k,n0_qdp,np1_qdp,r, nstep_end,region_num_threads,i,j real (kind=r8) :: dp_np1(np,np) real (kind=r8) :: dp_start(np,np,nlev+1,nets:nete),dp_end(np,np,nlev,nets:nete) logical :: compute_diagnostics @@ -317,15 +317,8 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst dp_end(:,:,:,ie) = elem(ie)%state%dp3d(:,:,:,tl%np1) end do end if -! if (single_column) then -! nets_in=1 -! nete_in=1 -! else - nets_in=nets - nete_in=nete -! endif call t_startf('vertical_remap') - call vertical_remap(hybrid,elem,fvm,hvcoord,tl%np1,np1_qdp,nets_in,nete_in) + call vertical_remap(hybrid,elem,fvm,hvcoord,tl%np1,np1_qdp,nets,nete) call t_stopf('vertical_remap') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 4a32cc4cb2..dd0ceca3f8 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -46,6 +46,9 @@ module dyn_comp use edge_mod, only: initEdgeBuffer, edgeVpack, edgeVunpack, FreeEdgeBuffer use edgetype_mod, only: EdgeBuffer_t use bndry_mod, only: bndry_exchange +use se_single_column_mod, only: scm_setinitial +use scamMod, only: single_column, have_divT3d, readiopdata, use_iop, setiopupdate_init, & + scmlon, scmlat implicit none private @@ -753,8 +756,13 @@ subroutine dyn_init(dyn_in, dyn_out) call set_phis(dyn_in) if (initial_run) then - call read_inidat(dyn_in) - call clean_iodesc_list() + call read_inidat(dyn_in) + if (use_iop .and. masterproc) then + call setiopupdate_init() + call readiopdata( hvcoord ) + call scm_setinitial(dyn_in%elem) + end if + call clean_iodesc_list() end if ! ! initialize diffusion in dycore @@ -979,7 +987,7 @@ subroutine dyn_run(dyn_state) use thread_mod, only: horz_num_threads use time_mod, only: tevolve use scamMod, only: single_column, use_3dfrc - use se_single_column_mod, only: apply_SC_forcing + use se_single_column_mod, only: apply_SC_forcing,ie_scm type(dyn_export_t), intent(inout) :: dyn_state @@ -998,6 +1006,7 @@ subroutine dyn_run(dyn_state) real(r8), allocatable, dimension(:,:,:) :: ps_before real(r8), allocatable, dimension(:,:,:) :: abs_ps_tend real (kind=r8) :: omega_cn(2,nelemd) !min and max of vertical Courant number + integer :: nets_in,nete_in !---------------------------------------------------------------------------- #ifdef debug_coupling @@ -1009,7 +1018,7 @@ subroutine dyn_run(dyn_state) if (iam >= par%nprocs) return - if (.not. use_3dfrc) then + if (.not. use_3dfrc ) then ldiag = hist_fld_active('ABS_dPSdt') if (ldiag) then @@ -1121,7 +1130,14 @@ subroutine dyn_run(dyn_state) end if ! forward-in-time RK, with subcycling - call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets, nete, & + if (single_column) then + nets_in=ie_scm + nete_in=ie_scm + else + nets_in=nets + nete_in=nete + end if + call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets_in, nete_in, & tstep, TimeLevel, hvcoord, n, single_column, omega_cn) if (ldiag) then @@ -1357,8 +1373,10 @@ subroutine read_inidat(dyn_in) allocate(dbuf3(npsq,nlev,nelemd)) ! Check that columns in IC file match grid definition. - call check_file_layout(fh_ini, elem, dyn_cols, 'ncdata', .true.) - + if (.not. single_column) then + call check_file_layout(fh_ini, elem, dyn_cols, 'ncdata', .true.) + end if + ! Read 2-D field fieldname = 'PS' @@ -2056,7 +2074,7 @@ subroutine check_file_layout(file, elem, dyn_cols, file_desc, dyn_ok) end if ierr = pio_inq_dimlen(file, ncol_did, ncol_size) - if (ncol_size /= dyn_cols) then + if (ncol_size /= dyn_cols .and. .not. single_column) then if (masterproc) then write(iulog, '(a,2(a,i0))') trim(sub), ': ncol_size=', ncol_size, & ' : dyn_cols=', dyn_cols diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 7e4cd1d366..af6dce74db 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -11,7 +11,7 @@ module se_single_column_mod wfld, psobs,uobs,vobs,tobs,divt,divQ,divT3d,divq3d,precobs,lhflxobs, & shflxobs, tground, have_ps, have_tg, have_lhflx, have_shflx, have_t, & have_omega, have_cldliq, have_divt, have_divq, have_divt3d, have_divq3d, & - use_3dfrc + use_3dfrc,scmlat,scmlon use constituents, only: cnst_get_ind, pcnst use dimensions_mod, only: nelemd, np, nlev use time_manager, only: get_nstep, is_first_step, get_step_size, is_first_restart_step @@ -28,8 +28,11 @@ module se_single_column_mod public scm_setfield public apply_SC_forcing public iop_broadcast +public scm_dyn_grid_indicies -integer :: tl_f, tl_fqdp +integer, public :: indx_scm, ie_scm, i_scm, j_scm + +integer :: tl_f, tl_fqdp, thelev !========================================================================= contains @@ -45,10 +48,12 @@ subroutine scm_setinitial(elem) type(element_t), intent(inout) :: elem(:) - integer i, j, k, cix, ie, thelev + integer i, j, k, cix, ie integer inumliq, inumice, icldliq, icldice integer :: tl_f, tl_fqdp + call scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) + tl_f = timelevel%n0 call TimeLevel_Qdp(timelevel, qsplit, tl_fqdp) @@ -58,61 +63,52 @@ subroutine scm_setinitial(elem) call cnst_get_ind('CLDLIQ', icldliq) call cnst_get_ind('CLDICE', icldice) - do ie=1,nelemd - do j=1,np - do i=1,np - - ! Find level where tobs is no longer zero - thelev=1 - do k=1, NLEV - if (tobs(k) .ne. 0) then - thelev=k - go to 1000 - endif - enddo + ! Find level where tobs is no longer zero + thelev=1 + do k=1, NLEV + if (tobs(k) .ne. 0) then + thelev=k + go to 1000 + endif + enddo 1000 continue - - if (get_nstep() .le. 1) then - do k=1,thelev-1 - tobs(k)=elem(ie)%state%T(i,j,k,tl_f) - qobs(k)=elem(ie)%state%qdp(i,j,k,1,tl_fqdp)/elem(ie)%state%dp3d(i,j,k,tl_f) - enddo - else - tobs(:)=elem(ie)%state%T(i,j,:,tl_f) - qobs(:)=elem(ie)%state%qdp(i,j,:,1,tl_fqdp)/elem(ie)%state%dp3d(i,j,:,tl_f) - endif - - if (get_nstep() .eq. 0) then - do cix = 1, pcnst -!jt if (scm_zero_non_iop_tracers) elem(ie)%state%qdp(i,j,:,cix,tl_qdp_np0) = qmin(cix)*elem(ie)%state%dp3d(i,j,:,tl_qdp_np0) - elem(ie)%state%qdp(i,j,:,cix,tl_fqdp) = qmin(cix)*elem(ie)%state%dp3d(i,j,:,tl_f) - end do - do k=thelev, NLEV - if (have_t) elem(ie)%state%T(i,j,k,tl_f)=tobs(k) - if (have_q) elem(ie)%state%qdp(i,j,k,1,tl_fqdp)=qobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) -!jt if (have_q) elem(ie)%state%qdp(i,j,k,1,tl_f)=qobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) - - enddo - - do k=1,NLEV - if (have_ps) elem(ie)%state%psdry(i,j) = psobs - if (have_u) elem(ie)%state%v(i,j,1,k,tl_f) = uobs(k) - if (have_v) elem(ie)%state%v(i,j,2,k,tl_f) = vobs(k) - if (have_numliq) elem(ie)%state%qdp(i,j,k,inumliq,tl_fqdp) = numliqobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) - if (have_cldliq) elem(ie)%state%qdp(i,j,k,icldliq,tl_fqdp) = cldliqobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) - if (have_numice) elem(ie)%state%qdp(i,j,k,inumice,tl_fqdp) = numiceobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) - if (have_cldice) elem(ie)%state%qdp(i,j,k,icldice,tl_fqdp) = cldiceobs(k)*elem(ie)%state%dp3d(i,j,k,tl_f) - if (have_omega) elem(ie)%derived%omega(i,j,k) = wfld(k) - enddo - - endif - - enddo - enddo - enddo - endif + if (get_nstep() .le. 1) then + do k=1,thelev-1 + tobs(k)=elem(ie_scm)%state%T(i_scm,j_scm,k,tl_f) + qobs(k)=elem(ie_scm)%state%qdp(i_scm,j_scm,k,1,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + enddo + else + tobs(:)=elem(ie_scm)%state%T(i_scm,j_scm,:,tl_f) + qobs(:)=elem(ie_scm)%state%qdp(i_scm,j_scm,:,1,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:,tl_f) + endif + + if (get_nstep() .eq. 0) then + !jt do cix = 1, pcnst + !jt if (scm_zero_non_iop_tracers) elem(ie_scm)%state%qdp(i,j,:,cix,tl_qdp_np0) = qmin(cix)*elem(ie_scm)%state%dp3d(i,j,:,tl_qdp_np0) + !jt elem(ie_scm)%state%qdp(ii,j,:,cix,tl_fqdp) = qmin(cix)*elem(ie_scm)%state%dp3d(ii,j,:,tl_f) + !jt end do + do k=thelev, NLEV + if (have_t) elem(ie_scm)%state%T(i_scm,j_scm,k,tl_f)=tobs(k) + if (have_q) elem(ie_scm)%state%qdp(i_scm,j_scm,k,1,tl_fqdp)=qobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + enddo + + do k=1,NLEV + if (have_ps) elem(ie_scm)%state%psdry(i_scm,j_scm) = psobs + if (have_u) elem(ie_scm)%state%v(i_scm,j_scm,1,k,tl_f) = uobs(k) + if (have_v) elem(ie_scm)%state%v(i_scm,j_scm,2,k,tl_f) = vobs(k) + if (have_numliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumliq,tl_fqdp) = numliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_cldliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldliq,tl_fqdp) = cldliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_numice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumice,tl_fqdp) = numiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_cldice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldice,tl_fqdp) = cldiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_omega) elem(ie_scm)%derived%omega(i_scm,j_scm,k) = wfld(k) + enddo + + endif + + endif + end subroutine scm_setinitial subroutine scm_setfield(elem,iop_update_phase1) @@ -122,37 +118,46 @@ subroutine scm_setfield(elem,iop_update_phase1) ! provided by IOP file !---------------------------------------------------------- + use control_mod, only: qsplit + use dyn_grid, only: TimeLevel + implicit none logical, intent(in) :: iop_update_phase1 type(element_t), intent(inout) :: elem(:) integer i, j, k, ie + integer :: tl_f, tl_fqdp - do ie=1,nelemd - if (have_ps .and. use_camiop .and. .not. iop_update_phase1) elem(ie)%state%psdry(:,:) = psobs - if (have_ps .and. .not. use_camiop) elem(ie)%state%psdry(:,:) = psobs - do i=1, NLEV - if (have_omega .and. iop_update_phase1) elem(ie)%derived%omega(:,:,i)=wfld(i) ! set t to tobs at first - end do - end do + tl_f = timelevel%n0 + call TimeLevel_Qdp(timelevel, qsplit, tl_fqdp) + if (have_ps .and. use_camiop .and. .not. iop_update_phase1) elem(ie_scm)%state%psdry(:,:) = psobs + if (have_ps .and. .not. use_camiop) elem(ie_scm)%state%psdry(:,:) = psobs + do k=1, NLEV + if (have_omega .and. iop_update_phase1) elem(ie_scm)%derived%omega(:,:,k)=wfld(k) ! set t to tobs at first + if (k < thelev) then + tobs(k) = elem(ie_scm)%state%T(i_scm,j_scm,k,tl_f) + qobs(k) = elem(ie_scm)%state%qdp(i_scm,j_scm,k,1,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + uobs(k) = elem(ie_scm)%state%v(i_scm,j_scm,1,k,tl_f) + vobs(k) = elem(ie_scm)%state%v(i_scm,j_scm,2,k,tl_f) + end if + end do + end subroutine scm_setfield subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) ! use scamMod, only: single_column, use_3dfrc - use dimensions_mod, only : np, nlev, npsq,qsize_d - - use hybvcoord_mod, only : hvcoord_t - use element_mod, only : element_t + use dimensions_mod, only: np, nlev, npsq,qsize_d + use hybvcoord_mod, only: hvcoord_t + use element_mod, only: element_t use physconst, only: rair use time_mod use time_manager, only: get_nstep - use shr_const_mod, only: SHR_CONST_PI use control_mod, only: qsplit use apply_iop_forcing_mod, only:advance_iop_forcing, advance_iop_nudging - + use ppgrid, only:begchunk integer :: n,nets,nete type (element_t) , intent(inout), target :: elem(:) type (hvcoord_t) :: hvcoord @@ -160,20 +165,31 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) logical :: t_before_advance integer :: tl_qdp_np0,tl_qdp_np1 - integer :: ie,k,i,j,t,ii,jj,m + integer :: ie,k,i,j,t,m real (r8), dimension(nlev) :: p real (r8) ::dt integer ::nelemd_todo, np_todo logical ::scm_multcols = .false. logical ::iop_nudge_tq = .false. + + +!$$ real (r8), pointer :: q_phys_frc(:,:) +!$$ real (r8) :: q3m2(nlev,pcnst), q3m1(nlev,pcnst),q3(nlev,pcnst) +!$$ real (r8), pointer :: t_phys_frc(:), u_phys_frc(:), v_phys_frc(:),t_vfcst(:),u_vfcst(:),v_vfcst(:) +!$$ real (r8), dimension(nlev) :: t3, u3, v3 +!$$ real (r8), pointer :: t3m1(:), u3m1(:), v3m1(:), t3m2(:), u3m2(:), v3m2(:) +!$$ real (r8), pointer :: psm1 +!$$ real (r8), dimension(nlev) :: relaxt, relaxq +!$$ real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn +!$$ real (r8), dimension(npsq,nlev) :: tdiff_out, qdiff_out +!$$ real (r8) :: etamid(nlev) +!$$ real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update, q_phys_frc real (r8), dimension(nlev) :: t_phys_frc, t_update, u_update, v_update real (r8), dimension(nlev) :: t_in, u_in, v_in real (r8), dimension(nlev) :: relaxt, relaxq real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn - real (r8), dimension(npsq,nlev) :: tdiff_out, qdiff_out - real (r8) :: dpscm(nlev) !----------------------------------------------------------------------- @@ -181,58 +197,105 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) call TimeLevel_Qdp(tl, qsplit, tl_fqdp) - ! For SCM only one column is considered - ie = 35 - ii=3 - jj=4 - +!$$ dt = get_step_size() +!$$ +!$$ ! Set initial profiles for current column +!$$ do m=1,pcnst +!$$ q3m2(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) +!$$ q3m1(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) +!$$!jt qminus(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f)+q_phys_frc(:nlev) +!$$ end do +!$$ t_vfcst => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%n0) +!$$ u_vfcst => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%n0) +!$$ v_vfcst => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%n0) +!$$ u3m2 => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%n0) +!$$ v3m2 => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%n0) +!$$ t3m2 => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%n0) +!$$ u3m1 => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%nm1) +!$$ v3m1 => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%nm1) +!$$ t3m1 => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%nm1) +!$$ psm1 => elem(ie_scm)%state%psdry(i_scm,j_scm) +!$$!!$ if (.not. use_3dfrc ) then +!$$!!$ t_phys_frc(:) = 0.0_r8 +!$$!!$ else +!$$ t_phys_frc => elem(ie_scm)%derived%fT(i_scm,j_scm,:) +!$$ u_phys_frc => elem(ie_scm)%derived%FM(i_scm,j_scm,1,:) +!$$ v_phys_frc => elem(ie_scm)%derived%FM(i_scm,j_scm,2,:) +!$$!jt q_phys_frc => elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:)*dt/elem(ie_scm)%stat +!$$!jt qminus(:nlev) = q3m2+q_phys_frc(:,:) +!$$!!$ endif +!$$ +!$$ do k=1,nlev +!$$ etamid(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*psm1 +!$$ end do +!$$ +!$$ call forecast(begchunk,psm1,& +!$$ psm1,psm1,u3,& +!$$ u3m2,u3m2,& +!$$ v3,v3m2,& +!$$ v3m2,t3,& +!$$ t3m2,t3m2,& +!$$ q3,q3m2,q3m2,dt,t_phys_frc,u_phys_frc,v_phys_frc,& +!$$ q3m2,etamid,q3m2,1) + +!!$ ! Call the main subroutine to update t, q, u, and v according to +!!$ ! large scale forcing as specified in IOP file. +!!$ call advance_iop_forcing(dt ,hvcoord ,psm1 , & ! In +!!$ u3m1 ,u3m2 ,u_phys_frc , & ! In +!!$ v3m1 ,v3m2 ,v_phys_frc , & ! In +!!$ t3m1 ,t3m2 ,t_phys_frc , & ! In +!!$ q3m1 ,q3m2 ,q_phys_frc , & ! In +!!$ u_vfcst ,v_vfcst ,t_vfcst , & ! In +!!$ q_vfcst , & ! In +!!$ u3 ,v3 ,t3 , & ! Out +!!$ q3 ) ! Out dt = get_step_size() ! Set initial profiles for current column do m=1,pcnst - stateQ_in(:nlev,m) = elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp)/elem(ie)%state%dp3d(ii,jj,:nlev,tl_f) + stateQ_in(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) end do - t_in(:nlev) = elem(ie)%state%T(ii,jj,:nlev,tl_f) - u_in(:nlev) = elem(ie)%state%v(ii,jj,1,:nlev,tl_f) - v_in(:nlev) = elem(ie)%state%v(ii,jj,2,:nlev,tl_f) + t_in(:nlev) = elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl_f) + u_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl_f) + v_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl_f) !!$ if (.not. use_3dfrc ) then !!$ t_phys_frc(:) = 0.0_r8 !!$ else - t_phys_frc(:) = elem(ie)%derived%fT(ii,jj,:) - q_phys_frc(:,:) = elem(ie)%derived%fQ(ii,jj,:,:)/dt + t_phys_frc(:) = elem(ie_scm)%derived%fT(i_scm,j_scm,:) + q_phys_frc(:,:) = elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:)/dt !!$ endif ! Call the main subroutine to update t, q, u, and v according to ! large scale forcing as specified in IOP file. - call advance_iop_forcing(dt,elem(ie)%state%psdry(ii,jj),& ! In + call advance_iop_forcing(dt,elem(ie_scm)%state%psdry(i_scm,j_scm),& ! In u_in,v_in,t_in,stateQ_in,t_phys_frc, q_phys_frc, hvcoord, & ! In u_update,v_update,t_update,q_update) ! Out ! Nudge to observations if desired, for T & Q only if in SCM mode if (iop_nudge_tq ) then - call advance_iop_nudging(dt,elem(ie)%state%psdry(ii,jj),& ! In + call advance_iop_nudging(dt,elem(ie_scm)%state%psdry(i_scm,j_scm),& ! In t_update,q_update(:,1), hvcoord, & ! Inn t_update,q_update(:,1),relaxt,relaxq) ! Out endif if (use_3dfrc) then ! vertical remap of dynamics not run need to update state%dp3d using new psdry do k=1,nlev - elem(ie)%state%dp3d(ii,jj,k,tl_f) = (hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + (hvcoord%hybi(k+1)-hvcoord%hybi(k))*elem(ie)%state%psdry(ii,jj) + elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) = (hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + (hvcoord%hybi(k+1)-hvcoord%hybi(k))*elem(ie_scm)%state%psdry(i_scm,j_scm) end do end if ! Update qdp using new dp3d do m=1,pcnst ! Update the Qdp array - elem(ie)%state%Qdp(ii,jj,:nlev,m,tl_fqdp) = & - q_update(:nlev,m) * elem(ie)%state%dp3d(ii,jj,:nlev,tl_f) + elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp) = & + q_update(:nlev,m) * elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) enddo ! Update prognostic variables to the current values - elem(ie)%state%T(ii,jj,:,tl_f) = t_update(:) - elem(ie)%state%v(ii,jj,1,:,tl_f) = u_update(:) - elem(ie)%state%v(ii,jj,2,:,tl_f) = v_update(:) + elem(ie_scm)%state%T(i_scm,j_scm,:,tl_f) = t_update(:) + elem(ie_scm)%state%v(i_scm,j_scm,1,:,tl_f) = u_update(:) + elem(ie_scm)%state%v(i_scm,j_scm,2,:,tl_f) = v_update(:) ! Evaluate the differences in state information from observed ! (done for diganostic purposes only) @@ -240,7 +303,7 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) tdiff_dyn(k) = t_update(k) - tobs(k) qdiff_dyn(k) = q_update(k,1) - qobs(k) end do - + write(6,*)'tdiff=',tdiff_dyn ! Add various diganostic outfld calls call outfld('TDIFF',tdiff_dyn,1,begchunk) call outfld('QDIFF',qdiff_dyn,1,begchunk) @@ -309,5 +372,60 @@ subroutine iop_broadcast() #endif end subroutine iop_broadcast + +!========================================================================= + subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) + + !--------------------------------------------------------- + ! Purpose: When running DP-CRM, broadcast relevant logical + ! flags and data to all processors + !---------------------------------------------------------- + + use dimensions_mod, only: nlev, nelemd + use element_mod, only: element_t + use shr_const_mod, only: pi => SHR_CONST_PI + use cam_abortutils, only: endrun + + type(element_t), intent(in) :: elem(:) + real (r8), intent(in) :: scmlat,scmlon + integer, intent(out) :: ie_scm, j_scm, i_scm, indx_scm + + integer :: i, j, indx, ie + real(r8) :: scmposlon, minpoint, testlat, testlon, testval + integer :: ierr + real(r8), parameter :: rad2deg = 180.0_r8 / pi + + ie_scm=0 + i_scm=0 + j_scm=0 + indx_scm=0 + minpoint = 1000 + scmposlon = mod(scmlon + 360._r8,360._r8) + do ie=1, nelemd + indx=1 + do j=1, np + do i=1, np + testlat=elem(ie)%spherep(i,j)%lat * rad2deg + testlon=elem(ie)%spherep(i,j)%lon * rad2deg + if (testlon .lt. 0._r8) testlon=testlon+360._r8 + testval=abs(scmlat-testlat)+abs(scmposlon-testlon) + if (testval .lt. minpoint) then + ie_scm=ie + indx_scm=indx + i_scm=i + j_scm=j + minpoint=testval + if (minpoint .lt. 1.e-7) minpoint=0._r8 + endif + indx=indx+1 + enddo + enddo + enddo + + if (ie_scm == 0 .or. i_scm == 0 .or. j_scm == 0 .or. indx_scm == 0) then + call endrun('Could not find closest SCM point on input datafile') + endif + + end subroutine scm_dyn_grid_indicies end module se_single_column_mod diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index 24da1e222f..7101daf4b9 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -133,11 +133,11 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & if (use_iop .and. masterproc) then - if (is_first_step()) then - call setiopupdate_init() - else +!!$ if (is_first_step()) then +!!$ call setiopupdate_init() +!!$ else call setiopupdate - endif +!!$ endif end if if (single_column) then @@ -145,14 +145,16 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & ! If first restart step then ensure that IOP data is read if (is_first_restart_step()) then iop_update_phase1 = .false. - call scm_setinitial(dyn_out%elem) - if (masterproc) call readiopdata( iop_update_phase1,hvcoord ) +!jt call scm_setinitial(dyn_out%elem) +!jt if (masterproc) call readiopdata( iop_update_phase1,hvcoord ) + if (masterproc) call readiopdata( hvcoord ) call iop_broadcast() endif iop_update_phase1 = .true. if ((is_first_restart_step() .or. doiopupdate) .and. masterproc) then - call readiopdata(iop_update_phase1,hvcoord) +!jt call readiopdata(iop_update_phase1, hvcoord) + call readiopdata(hvcoord) endif call iop_broadcast() @@ -294,8 +296,9 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) iop_update_phase1 = .false. if (doiopupdate) then - call scm_setinitial(dyn_out%elem) - if (masterproc) call readiopdata(iop_update_phase1,hvcoord) +!jt call scm_setinitial(dyn_out%elem) +!jt if (masterproc) call readiopdata(iop_update_phase1,hvcoord) + if (masterproc) call readiopdata(hvcoord) call iop_broadcast() call scm_setfield(dyn_out%elem,iop_update_phase1) endif diff --git a/src/infrastructure/phys_grid.F90 b/src/infrastructure/phys_grid.F90 index 203ce4e583..6ca2276c61 100644 --- a/src/infrastructure/phys_grid.F90 +++ b/src/infrastructure/phys_grid.F90 @@ -21,7 +21,7 @@ module phys_grid ! !------------------------------------------------------------------------------ use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: begchunk, endchunk + use ppgrid, only: begchunk, endchunk, pver, pverp, pcols use physics_column_type, only: physics_column_t use perf_mod, only: t_adj_detailf, t_startf, t_stopf @@ -112,8 +112,8 @@ module phys_grid !!XXgoldyXX: ^ temporary interface to allow old code to compile - integer, protected, public :: pver = 0 - integer, protected, public :: pverp = 0 +!jt integer, protected, public :: pver = 0 +!jt integer, protected, public :: pverp = 0 integer, protected, public :: num_global_phys_cols = 0 integer, protected, public :: columns_on_task = 0 integer, protected, public :: index_top_layer = 0 @@ -132,7 +132,6 @@ subroutine phys_grid_readnl(nlfile) use cam_logfile, only: iulog use spmd_utils, only: mpicom, mstrid=>masterprocid, masterproc use spmd_utils, only: mpi_integer - use ppgrid, only: pcols character(len=*), intent(in) :: nlfile @@ -186,7 +185,6 @@ subroutine phys_grid_init() use cam_abortutils, only: endrun use cam_logfile, only: iulog use spmd_utils, only: npes, mpicom, masterprocid, masterproc, iam - use ppgrid, only: pcols use dyn_grid, only: get_dyn_grid_info, physgrid_copy_attributes_d use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register use cam_grid_support, only: iMap, hclen => max_hcoordname_len @@ -194,7 +192,6 @@ subroutine phys_grid_init() use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists use shr_const_mod, only: PI => SHR_CONST_PI use scamMod, only: scmlon,scmlat,single_column - use cam_grid_support, only: max_hcoordname_len ! Local variables integer :: index @@ -224,7 +221,7 @@ subroutine phys_grid_init() real(r8), parameter :: rarea_sphere = 1.0_r8 / (4.0_r8*PI) real (r8), allocatable :: dynlats(:),dynlons(:),pos_dynlons(:) real (r8) :: pos_scmlon,minpoint,testpoint - integer :: scm_col_index, i + integer :: scm_col_index, i, num_lev nullify(lonvals) nullify(latvals) @@ -243,7 +240,7 @@ subroutine phys_grid_init() call t_startf("phys_grid_init") ! Gather info from the dycore - call get_dyn_grid_info(hdim1_d, hdim2_d, pver, index_top_layer, & + call get_dyn_grid_info(hdim1_d, hdim2_d, num_lev, index_top_layer, & index_bottom_layer, unstructured, dyn_columns) ! Set up the physics decomposition @@ -274,10 +271,8 @@ subroutine phys_grid_init() else phys_columns_on_task = columns_on_task end if - ! hdim1_d * hdim2_d is the total number of columns num_global_phys_cols = hdim1_d * hdim2_d - pverp = pver + 1 !!XXgoldyXX: Can we enforce interface numbering separate from dycore? !!XXgoldyXX: This will work for both CAM and WRF/MPAS physics !!XXgoldyXX: This only has a 50% chance of working on a single level model @@ -316,23 +311,21 @@ subroutine phys_grid_init() col_index = col_index + 1 ! Copy information supplied by the dycore if (single_column) then - phys_columns(col_index) = dyn_columns(scm_col_index) - !single column only has 1 global column that is written to at offset 1 +!jt !scm physics only has 1 global column phys_columns(col_index)%global_col_num = 1 + phys_columns(col_index)%coord_indices(:)=scm_col_index else phys_columns(col_index) = dyn_columns(col_index) end if ! Fill in physics decomp info -!jt phys_columns(col_index)%coord_indices(:)=scm_col_index - phys_columns(col_index)%coord_indices(:)=1 phys_columns(col_index)%phys_task = iam phys_columns(col_index)%local_phys_chunk = index phys_columns(col_index)%phys_chunk_index = phys_col chunks(index)%phys_cols(phys_col) = col_index end do end do - + deallocate(dyn_columns) ! Add physics-package grid to set of CAM grids @@ -1220,7 +1213,6 @@ end subroutine dump_grid_map subroutine scatter_field_to_chunk(fdim,mdim,ldim, & hdim1d,globalfield,localchunks) use cam_abortutils, only: endrun - use ppgrid, only: pcols !----------------------------------------------------------------------- ! ! Purpose: DUMMY FOR WEAK SCALING TESTS diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 049db36fc7..0c1650e0db 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -882,7 +882,7 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) !----------------------------------------------------------------------- - if (.not.thermo_budget_history) return +!jt if (.not.thermo_budget_history) return do i=1,thermo_budget_num_vars name_out(i)=trim(thermo_budget_vars(i))//'_'//trim(outfld_name_suffix) @@ -945,14 +945,14 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) end if end if - call outfld(name_out(seidx) ,se , pcols ,lchnk ) - call outfld(name_out(poidx) ,po , pcols ,lchnk ) - call outfld(name_out(keidx) ,ke , pcols ,lchnk ) - call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) - call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) - call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) - call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) - call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) +!!$ call outfld(name_out(seidx) ,se , pcols ,lchnk ) +!!$ call outfld(name_out(poidx) ,po , pcols ,lchnk ) +!!$ call outfld(name_out(keidx) ,ke , pcols ,lchnk ) +!!$ call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) +!!$ call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) +!!$ call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) +!!$ call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) +!!$ call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) ! ! Axial angular momentum diagnostics ! @@ -983,8 +983,8 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) end do end do - call outfld(name_out(mridx) ,mr, pcols,lchnk ) - call outfld(name_out(moidx) ,mo, pcols,lchnk ) +!!$ call outfld(name_out(mridx) ,mr, pcols,lchnk ) +!!$ call outfld(name_out(moidx) ,mo, pcols,lchnk ) end subroutine tot_energy_phys diff --git a/src/physics/cam/chem_surfvals.F90 b/src/physics/cam/chem_surfvals.F90 index 4123753e32..6191c3a595 100644 --- a/src/physics/cam/chem_surfvals.F90 +++ b/src/physics/cam/chem_surfvals.F90 @@ -510,7 +510,7 @@ subroutine chem_surfvals_set() use ppgrid, only: begchunk, endchunk use mo_flbc, only: flbc_gmean_vmr, flbc_chk - use scamMod, only: single_column, scmiop_flbc_inti + use scamMod, only: single_column, scmiop_flbc_inti, use_camiop !---------------------------Local variables----------------------------- @@ -526,7 +526,7 @@ subroutine chem_surfvals_set() elseif (scenario_ghg == 'CHEM_LBC_FILE') then ! set mixing ratios from cam-chem/waccm lbc file call flbc_chk() - if (single_column) then + if (single_column .and. use_camiop) then call scmiop_flbc_inti( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) else ! set by lower boundary conditions file diff --git a/src/physics/cam/phys_grid.F90 b/src/physics/cam/phys_grid.F90 index f737c835de..ca1670e4c2 100644 --- a/src/physics/cam/phys_grid.F90 +++ b/src/physics/cam/phys_grid.F90 @@ -1,1206 +1,4840 @@ module phys_grid - -!------------------------------------------------------------------------------ +!----------------------------------------------------------------------- +! +! Purpose: Definition of physics computational horizontal grid. +! +! Method: Variables are private; interface routines used to extract +! information for use in user code. +! +! Entry points: +! phys_grid_readnl read namelist options +! +! phys_grid_init initialize chunk'ed data structure +! phys_grid_initialized get physgrid_set flag +! +! get_chunk_indices_p get local chunk index range +! get_ncols_p get number of columns for a given chunk +! get_grid_dims return physics grid axis global sizes +! get_xxx_all_p get global indices, coordinates, or values +! for a given chunk +! get_xxx_vec_p get global indices, coordinates, or values +! for a subset of the columns in a chunk +! get_xxx_p get global indices, coordinates, or values +! for a single column +! where xxx is +! area for column surface area (in radians squared) +! gcol for global column index +! lat for global latitude index +! lon for global longitude index +! rlat for latitude coordinate (in radians) +! rlon for longitude coordinate (in radians) +! wght for column integration weight +! +! scatter_field_to_chunk +! distribute field +! to decomposed chunk data structure +! gather_chunk_to_field +! reconstruct field +! from decomposed chunk data structure +! +! read_chunk_from_field +! read and distribute field +! to decomposed chunk data structure +! write_field_from_chunk +! write field +! from decomposed chunk data structure ! -! The phys_grid module represents the CAM physics decomposition. +! block_to_chunk_send_pters +! return pointers into send buffer where data +! from decomposed fields should +! be copied to +! block_to_chunk_recv_pters +! return pointers into receive buffer where data +! for decomposed chunk data structures should +! be copied from +! transpose_block_to_chunk +! transpose buffer containing decomposed +! fields to buffer +! containing decomposed chunk data structures ! -! phys_grid_init receives the physics column info (area, weight, centers) -! from the dycore. -! The routine then creates the physics decomposition which -! is the arrangement of columns across the atmosphere model's -! MPI tasks as well as the arrangement into groups to -! facilitate efficient threading. -! The routine then creates a grid object to allow for data -! to be read into and written from this decomposition. -! The phys_grid module also provides interfaces for retrieving information -! about the decomposition +! chunk_to_block_send_pters +! return pointers into send buffer where data +! from decomposed chunk data structures should +! be copied to +! chunk_to_block_recv_pters +! return pointers into receive buffer where data +! for decomposed fields should +! be copied from +! transpose_chunk_to_block +! transpose buffer containing decomposed +! chunk data structures to buffer +! containing decomposed fields ! -! Note: This current implementation does not perform load balancing, -! physics columns ae always on the same task as the corresponding -! column received from the dycore. +! chunk_index identify whether index is for a latitude or +! a chunk ! -!------------------------------------------------------------------------------ - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: begchunk, endchunk - use physics_column_type, only: physics_column_t - use perf_mod, only: t_adj_detailf, t_startf, t_stopf +! FOLLOWING ARE NO LONGER USED, AND ARE CURRENTLY COMMENTED OUT +! get_gcol_owner_p get owner of column +! for given global physics column index +! +! buff_to_chunk Copy from local buffer to local chunk data +! structure. (Needed for cpl6.) +! +! chunk_to_buff Copy from local chunk data structure to +! local buffer. (Needed for cpl6.) +! +! Author: Patrick Worley and John Drake +! +!----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4 + use physconst, only: pi + use ppgrid, only: pcols, pver, begchunk, endchunk +#if ( defined SPMD ) + use spmd_dyn, only: block_buf_nrecs, chunk_buf_nrecs, & + local_dp_map + use mpishorthand +#endif + use spmd_utils, only: iam, masterproc, npes, proc_smp_map, nsmps + use m_MergeSorts, only: IndexSet, IndexSort + use cam_abortutils, only: endrun + use perf_mod + use cam_logfile, only: iulog implicit none - private save -!!XXgoldyXX: v This needs to be removed to complete the weak scaling transition. - public :: SCATTER_FIELD_TO_CHUNK -!!XXgoldyXX: ^ This needs to be removed to complete the weak scaling transition. - - ! Physics grid management - public :: phys_grid_init ! initialize the physics grid - public :: phys_grid_readnl ! Read the phys_grid_nl namelist - public :: phys_grid_initialized - ! Local task interfaces - public :: get_nlcols_p ! Number of local columns - public :: get_area_p ! area of a physics column in radians squared - public :: get_wght_p ! weight of a physics column in radians squared - public :: get_rlat_p ! latitude of a physics column in radians - public :: get_rlon_p ! longitude of a physics column in radians - public :: get_rlat_all_p ! latitudes of physics cols in chunk (radians) - public :: get_rlon_all_p ! longitudes of physics cols in chunk (radians) - public :: get_lat_p ! latitude of a physics column in degrees - public :: get_lon_p ! longitude of a physics column in degrees - public :: get_lat_all_p ! latitudes of physics cols in chunk (degrees) - public :: get_lon_all_p ! longitudes of physics cols in chunk (degrees) - public :: get_area_all_p ! areas of physics cols in chunk - public :: get_wght_all_p ! weights of physics cols in chunk - public :: get_ncols_p ! number of columns in a chunk - public :: get_gcol_p ! global column index of a physics column - public :: get_gcol_all_p ! global col index of all phys cols in a chunk - public :: get_dyn_col_p ! dynamics local blk number and blk offset(s) - public :: get_chunk_info_p ! chunk index and col # of a physics column - public :: get_grid_dims ! return grid dimensions - ! Physics-dynamics coupling - public :: phys_decomp_to_dyn ! Transfer physics data to dynamics decomp - public :: dyn_decomp_to_phys ! Transfer dynamics data to physics decomp - - ! The identifier for the physics grid - integer, parameter, public :: phys_decomp = 100 - - !! PUBLIC TYPES - - ! Physics chunking (thread blocking) data - ! Note that chunks cover local data - type, public :: chunk - integer, private :: ncols = 1 ! # of grid columns in this chunk - integer, private :: chunk_index = -1 ! Local index of this chunk - integer, private, allocatable :: phys_cols(:) ! phys column indices +#if ( ! defined SPMD ) + integer, private :: block_buf_nrecs + integer, private :: chunk_buf_nrecs + logical, private :: local_dp_map=.true. +#endif + +! The identifier for the physics grid + integer, parameter, public :: phys_decomp = 100 + +! dynamics field grid information + integer, private :: hdim1_d, hdim2_d + ! dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then + ! hdim2_d == 1. + +! physics field data structures + integer, private :: ngcols ! global column count in physics grid (all) + integer, public :: num_global_phys_cols ! global column count in phys grid + ! (without holes) + + integer, dimension(:), allocatable, private :: dyn_to_latlon_gcol_map + ! map from unsorted (dynamics) to lat/lon sorted grid indices + integer, dimension(:), allocatable, private :: latlon_to_dyn_gcol_map + ! map from lat/lon sorted grid to unsorted (dynamics) indices + integer, dimension(:), allocatable, private :: lonlat_to_dyn_gcol_map + ! map from lon/lat sorted grid to unsorted (dynamics) indices + + integer, private :: clat_p_tot ! number of unique latitudes + integer, private :: clon_p_tot ! number of unique longitudes + + integer, dimension(:), allocatable, private :: clat_p_cnt ! number of repeats for each latitude + integer, dimension(:), allocatable, private :: clat_p_idx ! index in latlon ordering for first occurence + ! of latitude corresponding to given + ! latitude index + real(r8), dimension(:), allocatable :: clat_p ! unique latitudes (radians, increasing) + + + integer, dimension(:), allocatable, private :: clon_p_cnt ! number of repeats for each longitude + real(r8), dimension(:), allocatable :: clon_p ! unique longitudes (radians, increasing) + + integer, dimension(:), allocatable, private :: lat_p ! index into list of unique column latitudes + integer, dimension(:), allocatable, private :: lon_p ! index into list of unique column longitudes + +! chunk data structures + type chunk + integer :: ncols ! number of vertical columns + integer :: gcol(pcols) ! global physics column indices + integer :: lon(pcols) ! global longitude indices + integer :: lat(pcols) ! global latitude indices + integer :: owner ! id of process where chunk assigned + integer :: lcid ! local chunk index end type chunk - !! PRIVATE DATA - - ! dynamics field grid information - ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid - ! data structure, If 1D data structure, then hdim2_d == 1. - integer :: hdim1_d, hdim2_d - - ! Physics decomposition information - type(physics_column_t), allocatable :: phys_columns(:) - - type(chunk), private, pointer :: chunks(:) => NULL() ! (begchunk:endchunk) + integer :: nchunks ! global chunk count + type (chunk), dimension(:), allocatable, public :: chunks + ! global computational grid + + integer, dimension(:), allocatable, private :: npchunks + ! number of chunks assigned to each process + + type lchunk + integer :: ncols ! number of vertical columns + integer :: cid ! global chunk index + integer :: gcol(pcols) ! global physics column indices + real(r8) :: area(pcols) ! column surface area (from dynamics) + real(r8) :: wght(pcols) ! column integration weight (from dynamics) + end type lchunk + + integer, private :: nlchunks ! local chunk count + type (lchunk), dimension(:), allocatable, private :: lchunks + ! local chunks + + type knuhc + integer :: chunkid ! chunk id + integer :: col ! column index in chunk + end type knuhc + + type (knuhc), dimension(:), allocatable, private :: knuhcs + ! map from global column indices + ! to chunk'ed grid + +! column mapping data structures + type column_map + integer :: chunk ! global chunk index + integer :: ccol ! column ordering in chunk + end type column_map + + integer, private :: nlcols ! local column count + type (column_map), dimension(:), allocatable, private :: pgcols + ! ordered list of columns (for use in gather/scatter) + ! NOTE: consistent with local ordering + +! column remap data structures + integer, dimension(:), allocatable, private :: gs_col_num + ! number of columns scattered to each process in + ! field_to_chunk scatter + integer, dimension(:), allocatable, private :: gs_col_offset + ! offset of columns (-1) in pgcols scattered to + ! each process in field_to_chunk scatter + + integer, dimension(:), allocatable, private :: btofc_blk_num + ! number of grid points scattered to each process in + ! block_to_chunk alltoallv, and gathered from each + ! process in chunk_to_block alltoallv + + integer, dimension(:), allocatable, private :: btofc_chk_num + ! number of grid points gathered from each process in + ! block_to_chunk alltoallv, and scattered to each + ! process in chunk_to_block alltoallv + + type btofc_pters + integer :: ncols ! number of columns in block + integer :: nlvls ! number of levels in columns + integer, dimension(:,:), pointer :: pter + end type btofc_pters + type (btofc_pters), dimension(:), allocatable, private :: btofc_blk_offset + ! offset in btoc send array (-1) where + ! (blockid, bcid, k) column should be packed in + ! block_to_chunk alltoallv, AND + ! offset in ctob receive array (-1) from which + ! (blockid, bcid, k) column should be unpacked in + ! chunk_to_block alltoallv + + type (btofc_pters), dimension(:), allocatable, private :: btofc_chk_offset + ! offset in btoc receive array (-1) from which + ! (lcid, i, k) data should be unpacked in + ! block_to_chunk alltoallv, AND + ! offset in ctob send array (-1) where + ! (lcid, i, k) data should be packed in + ! chunk_to_block alltoallv + +! miscellaneous phys_grid data + integer, private :: dp_coup_steps ! number of swaps in transpose algorithm + integer, dimension(:), private, allocatable :: dp_coup_proc + ! swap partner in each step of + ! transpose algorithm + logical :: physgrid_set = .false. ! flag indicates physics grid has been set + integer, private :: max_nproc_smpx ! maximum number of processes assigned to a + ! single virtual SMP used to define physics + ! load balancing + integer, private :: nproc_busy_d ! number of processes active during the dynamics + ! (assigned a dynamics block) + +! Physics grid decomposition options: +! -1: each chunk is a dynamics block +! 0: chunk definitions and assignments do not require interprocess comm. +! 1: chunk definitions and assignments do not require internode comm. +! 2: chunk definitions and assignments may require communication between all processes +! 3: chunk definitions and assignments only require communication with one other process +! 4: concatenated blocks, no load balancing, no interprocess communication + integer, private, parameter :: min_lbal_opt = -1 + integer, private, parameter :: max_lbal_opt = 5 + integer, private, parameter :: def_lbal_opt = 2 ! default + integer, private :: lbal_opt = def_lbal_opt + +! Physics grid load balancing options: +! 0: assign columns to chunks as single columns, wrap mapped across chunks +! 1: use (day/night; north/south) twin algorithm to determine load-balanced pairs of +! columns and assign columns to chunks in pairs, wrap mapped + integer, private, parameter :: min_twin_alg = 0 + integer, private, parameter :: max_twin_alg = 1 + integer, private, parameter :: def_twin_alg_lonlat = 1 ! default + integer, private, parameter :: def_twin_alg_unstructured = 0 + integer, private :: twin_alg = def_twin_alg_lonlat + +! target number of chunks per thread + integer, private, parameter :: min_chunks_per_thread = 1 + integer, private, parameter :: def_chunks_per_thread = & + min_chunks_per_thread ! default + integer, private :: chunks_per_thread = def_chunks_per_thread + +! Dynamics/physics transpose method for nonlocal load-balance: +! -1: use "0" if max_nproc_smpx and nproc_busy_d are both > npes/2; otherwise use "1" +! 0: use mpi_alltoallv +! 1: use point-to-point MPI-1 two-sided implementation +! 2: use point-to-point MPI-2 one-sided implementation if supported, +! otherwise use MPI-1 implementation +! 3: use Co-Array Fortran implementation if supported, +! otherwise use MPI-1 implementation +! 11-13: use mod_comm, choosing any of several methods internal to mod_comm. +! The method within mod_comm (denoted mod_method) has possible values 0,1,2 and +! is set according to mod_method = phys_alltoall - modmin_alltoall, where +! modmin_alltoall is 11. + integer, private, parameter :: min_alltoall = -1 + integer, private, parameter :: max_alltoall = 3 +# if defined(MODCM_DP_TRANSPOSE) + integer, private, parameter :: modmin_alltoall = 11 + integer, private, parameter :: modmax_alltoall = 13 +# endif + integer, private, parameter :: def_alltoall = -1 ! default + integer, private :: phys_alltoall = def_alltoall + + logical :: calc_memory_increase = .false. + +!======================================================================== +contains +!======================================================================== + +subroutine phys_grid_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, & + phys_mirror_decomp_req +#if defined(MODCM_DP_TRANSPOSE) + use mod_comm, only: phys_transpose_mod +#endif + use dycore, only: dycore_is + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: sub = 'phys_grid_readnl' + + integer :: phys_loadbalance + integer :: phys_twin_algorithm + integer :: phys_chnk_per_thd + + namelist /phys_grid_nl/ phys_alltoall, phys_loadbalance, phys_twin_algorithm, & + phys_chnk_per_thd + !----------------------------------------------------------------------------- + + ! Initialize namelist vars + phys_loadbalance = def_lbal_opt + + if (dycore_is('UNSTRUCTURED')) then + phys_twin_algorithm = def_twin_alg_unstructured + else + phys_twin_algorithm = def_twin_alg_lonlat + endif + + phys_chnk_per_thd = def_chunks_per_thread + + ! Read namelist + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'phys_grid_nl', status=ierr) + if (ierr == 0) then + read(unitn, phys_grid_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub//': FATAL: reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(phys_alltoall, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_alltoall") + call mpi_bcast(phys_loadbalance, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_loadbalance") + call mpi_bcast(phys_twin_algorithm, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_twin_algorithm") + call mpi_bcast(phys_chnk_per_thd, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: phys_chnk_per_thd") + + ! set module variables from namelist vars + + lbal_opt = phys_loadbalance + + if (lbal_opt == 3) then + phys_mirror_decomp_req = .true. + else + phys_mirror_decomp_req = .false. + endif + + twin_alg = phys_twin_algorithm + + chunks_per_thread = phys_chnk_per_thd + + ! Some consistency checks + + if (((phys_alltoall < min_alltoall) .or. & + (phys_alltoall > max_alltoall)) & +# if defined(MODCM_DP_TRANSPOSE) + .and. & + ((phys_alltoall < modmin_alltoall) .or. & + (phys_alltoall > modmax_alltoall)) & +# endif + ) then + if (masterproc) then + write(iulog,*) sub//': ERROR: phys_alltoall=', phys_alltoall, & + ' is out of range. It must be between ', min_alltoall, ' and ', max_alltoall + endif + call endrun(sub//': ERROR setting phys_alltoall') + endif +#if defined(SPMD) +#if defined(MODCM_DP_TRANSPOSE) + phys_transpose_mod = phys_alltoall +#endif +#endif + + if ((lbal_opt < min_lbal_opt).or.(lbal_opt > max_lbal_opt)) then + if (masterproc) then + write(iulog,*) sub//': ERROR: phys_loadbalance=', phys_loadbalance, & + ' is out of range. It must be between ', min_lbal_opt, ' and ', max_lbal_opt + endif + call endrun(sub//': ERROR setting phys_loadbalance') + endif - logical :: phys_grid_set = .false. + if ((twin_alg < min_twin_alg).or.(twin_alg > max_twin_alg)) then + if (masterproc) then + write(iulog,*) sub//': ERROR: phys_twin_algorithm=', phys_twin_algorithm, & + ' is out of range. It must be between ', min_twin_alg, ' and ', max_twin_alg + endif + call endrun(sub//': ERROR setting phys_twin_algorithm') + endif - logical :: calc_memory_increase = .false. + if (chunks_per_thread < min_chunks_per_thread) then + if (masterproc) then + write(iulog,*) sub//': ERROR: phys_chnk_per_thd=', phys_chnk_per_thd, & + ' is too small. It must not be smaller than ', min_chunks_per_thread + endif + call endrun(sub//': ERROR setting phys_chnk_per_thd') + endif + + + if (masterproc) then + write(iulog,*) 'PHYS_GRID options:' + write(iulog,*) ' Using PCOLS =', pcols + write(iulog,*) ' phys_loadbalance =', lbal_opt + write(iulog,*) ' phys_twin_algorithm =', twin_alg + write(iulog,*) ' phys_alltoall =', phys_alltoall + write(iulog,*) ' chunks_per_thread =', chunks_per_thread + end if + +end subroutine phys_grid_readnl + +!=============================================================================== + + integer function get_nlcols_p() + get_nlcols_p = nlcols + end function get_nlcols_p + + subroutine phys_grid_init( ) + !----------------------------------------------------------------------- + ! + ! Purpose: Physics mapping initialization routine: + ! + ! Method: + ! + ! Author: John Drake and Patrick Worley + ! + !----------------------------------------------------------------------- + use mpi, only: MPI_REAL8, MPI_MAX + use shr_mem_mod, only: shr_mem_getusage + use pmgrid, only: plev + use dycore, only: dycore_is + use dyn_grid, only: get_block_bounds_d, & + get_block_gcol_d, get_block_gcol_cnt_d, & + get_block_levels_d, get_block_lvl_cnt_d, & + get_block_owner_d, & + get_gcol_block_d, get_gcol_block_cnt_d, & + get_horiz_grid_dim_d, get_horiz_grid_d, physgrid_copy_attributes_d + use spmd_utils, only: pair, ceil2, masterprocid, mpicom + use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register + use cam_grid_support, only: iMap, max_hcoordname_len + use cam_grid_support, only: horiz_coord_t, horiz_coord_create + use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists + + ! + !------------------------------Arguments-------------------------------- + ! + ! + !---------------------------Local workspace----------------------------- + ! + integer :: i, j, jb, k, p ! loop indices + integer :: pre_i ! earlier index in loop iteration + integer :: clat_p_dex, clon_p_dex ! indices into unique lat. and lon. arrays + integer :: maxblksiz ! maximum number of columns in a dynamics block + integer :: beg_dex, end_dex ! index range + integer :: cid, lcid ! global and local chunk ids + integer :: max_ncols ! upper bound on number of columns in a block + integer :: ncols ! number of columns in current chunk + integer :: curgcol, curgcol_d ! current global column index + integer :: firstblock, lastblock ! global block indices + integer :: blksiz ! current block size + integer :: glbcnt, curcnt ! running grid point counts + integer :: curp ! current process id + integer :: block_cnt ! number of blocks containing data + ! for a given vertical column + integer :: numlvl ! number of vertical levels in block + ! column + integer :: levels(plev+1) ! vertical level indices + integer :: owner_d ! process owning given block column + integer :: owner_p ! process owning given chunk column + integer :: blockids(plev+1) ! block indices + integer :: bcids(plev+1) ! block column indices + + + ! column surface area (from dynamics) + real(r8), dimension(:), pointer :: area_d + + ! column surface areawt (from dynamics) + real(r8), dimension(:), pointer :: areawt_d + + ! column integration weight (from dynamics) + real(r8), dimension(:), allocatable :: wght_d + + ! chunk global ordering + integer, dimension(:), allocatable :: pchunkid + + ! permutation array used in physics column sorting; + ! reused later as work space in (lbal_opt == -1) logic + integer, dimension(:), allocatable :: cdex + + ! latitudes and longitudes and column area for dynamics columns + real(r8), dimension(:), allocatable :: clat_d + real(r8), dimension(:), allocatable :: clon_d + real(r8), dimension(:), allocatable :: lat_d + real(r8), dimension(:), allocatable :: lon_d + real(r8) :: clat_p_tmp + real(r8) :: clon_p_tmp + + ! Maps and values for physics grid + real(r8), pointer :: lonvals(:) + real(r8), pointer :: latvals(:) + real(r8), allocatable :: latdeg_p(:) + real(r8), allocatable :: londeg_p(:) + integer(iMap), pointer :: grid_map(:,:) + integer(iMap), allocatable :: coord_map(:) + type(horiz_coord_t), pointer :: lat_coord + type(horiz_coord_t), pointer :: lon_coord + integer :: gcols(pcols) + character(len=max_hcoordname_len), pointer :: copy_attributes(:) + character(len=max_hcoordname_len) :: copy_gridname + logical :: unstructured + real(r8) :: lonmin, latmin + real(r8) :: mem_hw_beg, mem_hw_end + real(r8) :: mem_beg, mem_end + + nullify(area_d) + nullify(lonvals) + nullify(latvals) + nullify(grid_map) + nullify(lat_coord) + nullify(lon_coord) + + if (calc_memory_increase) then + call shr_mem_getusage(mem_hw_beg, mem_beg) + end if + + call t_startf("phys_grid_init") + + !----------------------------------------------------------------------- + ! + ! Initialize physics grid, using dynamics grid + ! a) column coordinates + + call get_horiz_grid_dim_d(hdim1_d,hdim2_d) + ngcols = hdim1_d*hdim2_d + allocate( clat_d(1:ngcols) ) + allocate( clon_d(1:ngcols) ) + allocate( lat_d(1:ngcols) ) + allocate( lon_d(1:ngcols) ) + allocate( cdex(1:ngcols) ) + clat_d = 100000.0_r8 + clon_d = 100000.0_r8 + call get_horiz_grid_d(ngcols, clat_d_out=clat_d, clon_d_out=clon_d, lat_d_out=lat_d, lon_d_out=lon_d) + latmin = minval(lat_d) + lonmin = minval(lon_d) + + ! count number of "real" column indices + num_global_phys_cols = 0 + do i=1,ngcols + if (clon_d(i) < 100000.0_r8) then + num_global_phys_cols = num_global_phys_cols + 1 + endif + enddo + + ! sort over longitude and identify unique longitude coordinates + call IndexSet(ngcols,cdex) + call IndexSort(ngcols,cdex,clon_d,descend=.false.) + clon_p_tmp = clon_d(cdex(1)) + clon_p_tot = 1 + + do i=2,num_global_phys_cols + if (clon_d(cdex(i)) > clon_p_tmp) then + clon_p_tot = clon_p_tot + 1 + clon_p_tmp = clon_d(cdex(i)) + endif + enddo + + allocate( clon_p(1:clon_p_tot) ) + allocate( clon_p_cnt(1:clon_p_tot) ) + allocate( londeg_p(1:clon_p_tot) ) + + pre_i = 1 + clon_p_tot = 1 + clon_p(1) = clon_d(cdex(1)) + londeg_p(1) = lon_d(cdex(1)) + do i=2,num_global_phys_cols + if (clon_d(cdex(i)) > clon_p(clon_p_tot)) then + clon_p_cnt(clon_p_tot) = i-pre_i + pre_i = i + clon_p_tot = clon_p_tot + 1 + clon_p(clon_p_tot) = clon_d(cdex(i)) + londeg_p(clon_p_tot) = lon_d(cdex(i)) + endif + enddo + clon_p_cnt(clon_p_tot) = (num_global_phys_cols+1)-pre_i + + ! sort over latitude and identify unique latitude coordinates + call IndexSet(ngcols,cdex) + call IndexSort(ngcols,cdex,clat_d,descend=.false.) + clat_p_tmp = clat_d(cdex(1)) + clat_p_tot = 1 + do i=2,num_global_phys_cols + if (clat_d(cdex(i)) > clat_p_tmp) then + clat_p_tot = clat_p_tot + 1 + clat_p_tmp = clat_d(cdex(i)) + endif + enddo + + allocate( clat_p(1:clat_p_tot) ) + allocate( clat_p_cnt(1:clat_p_tot) ) + allocate( clat_p_idx(1:clat_p_tot) ) + allocate( latdeg_p(1:clat_p_tot) ) + + pre_i = 1 + clat_p_tot = 1 + clat_p(1) = clat_d(cdex(1)) + latdeg_p(1) = lat_d(cdex(1)) + do i=2,num_global_phys_cols + if (clat_d(cdex(i)) > clat_p(clat_p_tot)) then + clat_p_cnt(clat_p_tot) = i-pre_i + pre_i = i + clat_p_tot = clat_p_tot + 1 + clat_p(clat_p_tot) = clat_d(cdex(i)) + latdeg_p(clat_p_tot) = lat_d(cdex(i)) + endif + enddo + clat_p_cnt(clat_p_tot) = (num_global_phys_cols+1)-pre_i + + clat_p_idx(1) = 1 + do j=2,clat_p_tot + clat_p_idx(j) = clat_p_idx(j-1) + clat_p_cnt(j-1) + enddo + + deallocate(lat_d) + deallocate(lon_d) + + ! sort by longitude within latitudes + end_dex = 0 + do j=1,clat_p_tot + beg_dex = end_dex + 1 + end_dex = end_dex + clat_p_cnt(j) + call IndexSort(cdex(beg_dex:end_dex),clon_d,descend=.false.) + enddo + + ! Early clean-up, to minimize memory high water mark + ! (not executing find_partner or find_twin) + if (((twin_alg /= 1) .and. (lbal_opt /= 3)) .or. (lbal_opt == -1)) then + deallocate( clat_p_cnt) + end if + + ! save "longitude within latitude" column ordering + ! and determine mapping from unsorted global column index to + ! unique latitude/longitude indices + allocate( lat_p(1:ngcols) ) + allocate( lon_p(1:ngcols) ) + allocate( dyn_to_latlon_gcol_map(1:ngcols) ) + if (lbal_opt /= -1) then + allocate(latlon_to_dyn_gcol_map(1:num_global_phys_cols)) + end if + + clat_p_dex = 1 + lat_p = -1 + dyn_to_latlon_gcol_map = -1 + do i = 1, num_global_phys_cols + if (lbal_opt /= -1) latlon_to_dyn_gcol_map(i) = cdex(i) + dyn_to_latlon_gcol_map(cdex(i)) = i + + do while ((clat_p(clat_p_dex) < clat_d(cdex(i))) .and. & + (clat_p_dex < clat_p_tot)) + clat_p_dex = clat_p_dex + 1 + enddo + lat_p(cdex(i)) = clat_p_dex + enddo + + ! sort by latitude within longitudes + call IndexSet(ngcols,cdex) + call IndexSort(ngcols,cdex,clon_d,descend=.false.) + end_dex = 0 + do i=1,clon_p_tot + beg_dex = end_dex + 1 + end_dex = end_dex + clon_p_cnt(i) + call IndexSort(cdex(beg_dex:end_dex),clat_d,descend=.false.) + enddo + + ! Early clean-up, to minimize memory high water mark + ! (not executing find_twin) + if ((twin_alg /= 1) .or. (lbal_opt == -1)) deallocate( clon_p_cnt ) + + ! save "latitude within longitude" column ordering + ! (only need in find_twin) + if ((twin_alg == 1) .and. (lbal_opt /= -1)) & + allocate( lonlat_to_dyn_gcol_map(1:num_global_phys_cols) ) + + clon_p_dex = 1 + lon_p = -1 + do i=1,num_global_phys_cols + if ((twin_alg == 1) .and. (lbal_opt /= -1)) & + lonlat_to_dyn_gcol_map(i) = cdex(i) + do while ((clon_p(clon_p_dex) < clon_d(cdex(i))) .and. & + (clon_p_dex < clon_p_tot)) + clon_p_dex = clon_p_dex + 1 + enddo + lon_p(cdex(i)) = clon_p_dex + enddo + + ! Clean-up + deallocate( clat_d ) + deallocate( clon_d ) + deallocate( cdex ) + + ! + ! Determine block index bounds + ! + call get_block_bounds_d(firstblock,lastblock) + + ! Allocate storage to save number of chunks and columns assigned to each + ! process during chunk creation and assignment + ! + allocate( npchunks(0:npes-1) ) + allocate( gs_col_num(0:npes-1) ) + npchunks(:) = 0 + gs_col_num(:) = 0 + + ! + ! Option -1: each dynamics block is a single chunk + ! + if (lbal_opt == -1) then + ! + ! Check that pcols >= maxblksiz + ! + maxblksiz = 0 + do jb=firstblock,lastblock + maxblksiz = max(maxblksiz,get_block_gcol_cnt_d(jb)) + enddo + if (pcols < maxblksiz) then + write(iulog,*) 'pcols = ',pcols, ' maxblksiz=',maxblksiz + call endrun ('PHYS_GRID_INIT error: phys_loadbalance -1 specified but PCOLS < MAXBLKSIZ') + endif + + ! + ! Determine total number of chunks + ! + nchunks = (lastblock-firstblock+1) + + ! + ! Set max virtual SMP node size + ! + max_nproc_smpx = 1 + + ! + ! Allocate and initialize chunks data structure + ! + allocate( cdex(1:maxblksiz) ) + allocate( chunks(1:nchunks) ) + + do cid=1,nchunks + ! get number of global column indices in block + max_ncols = get_block_gcol_cnt_d(cid+firstblock-1) + ! fill cdex array with global indices from current block + call get_block_gcol_d(cid+firstblock-1,max_ncols,cdex) + + ncols = 0 + do i=1,max_ncols + ! check whether global index is for a column that dynamics + ! intends to pass to the physics + curgcol_d = cdex(i) + if (dyn_to_latlon_gcol_map(curgcol_d) /= -1) then + ! yes - then save the information + ncols = ncols + 1 + chunks(cid)%gcol(ncols) = curgcol_d + chunks(cid)%lat(ncols) = lat_p(curgcol_d) + chunks(cid)%lon(ncols) = lon_p(curgcol_d) + endif + enddo + chunks(cid)%ncols = ncols + enddo + + ! Clean-up + deallocate( cdex ) + deallocate( lat_p ) + deallocate( lon_p ) + + ! + ! Specify parallel decomposition + ! + do cid=1,nchunks +#if (defined SPMD) + p = get_block_owner_d(cid+firstblock-1) +#else + p = 0 +#endif + chunks(cid)%owner = p + npchunks(p) = npchunks(p) + 1 + gs_col_num(p) = gs_col_num(p) + chunks(cid)%ncols + enddo + ! + ! Set flag indicating columns in physics and dynamics + ! decompositions reside on the same processes + ! + local_dp_map = .true. + ! + else + ! + ! Option == 0: split local blocks into chunks, + ! while attempting to create load-balanced chunks. + ! Does not work with vertically decomposed blocks. + ! (default) + ! Option == 1: split SMP-local blocks into chunks, + ! while attempting to create load-balanced chunks. + ! Does not work with vertically decomposed blocks. + ! Option == 2: load balance chunks with respect to diurnal and + ! seaonsal cycles and wth respect to latitude, + ! and assign chunks to processes + ! in a way that attempts to minimize communication costs + ! Option == 3: divide processes into pairs and split + ! blocks assigned to these pairs into + ! chunks, attempting to create load-balanced chunks. + ! The process pairs are chosen to maximize load balancing + ! opportunities. + ! Does not work with vertically decomposed blocks. + ! Option == 4: concatenate local blocks, then + ! divide into chunks. + ! Does not work with vertically decomposed blocks. + ! Option == 5: split indiviudal blocks into chunks, + ! assigning columns using block ordering + ! + ! + ! Allocate and initialize chunks data structure, then + ! assign chunks to processes. + ! + call create_chunks(lbal_opt, chunks_per_thread) + + ! Early clean-up, to minimize memory high water mark + deallocate( lat_p ) + deallocate( lon_p ) + deallocate( latlon_to_dyn_gcol_map ) + if (twin_alg == 1) deallocate( lonlat_to_dyn_gcol_map ) + if (twin_alg == 1) deallocate( clon_p_cnt ) + if ((twin_alg == 1) .or. (lbal_opt == 3)) deallocate( clat_p_cnt ) + + ! + ! Determine whether dynamics and physics decompositions + ! are colocated, not requiring any interprocess communication + ! in the coupling. + local_dp_map = .true. + do cid=1,nchunks + do i=1,chunks(cid)%ncols + curgcol_d = chunks(cid)%gcol(i) + block_cnt = get_gcol_block_cnt_d(curgcol_d) + call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) + do jb=1,block_cnt + owner_d = get_block_owner_d(blockids(jb)) + if (owner_d /= chunks(cid)%owner) then + local_dp_map = .false. + endif + enddo + enddo + enddo + endif + ! + ! Allocate and initialize data structures for gather/scatter + ! + allocate( pgcols(1:num_global_phys_cols) ) + allocate( gs_col_offset(0:npes) ) + allocate( pchunkid(0:npes) ) + + ! Initialize pchunkid and gs_col_offset by summing + ! number of chunks and columns per process, respectively + pchunkid(0) = 0 + gs_col_offset(0) = 0 + do p=1,npes-1 + pchunkid(p) = pchunkid(p-1) + npchunks(p-1) + gs_col_offset(p) = gs_col_offset(p-1) + gs_col_num(p-1) + enddo + + ! Determine local ordering via "process id" bin sort + do cid=1,nchunks + p = chunks(cid)%owner + pchunkid(p) = pchunkid(p) + 1 + + chunks(cid)%lcid = pchunkid(p) + lastblock + + curgcol = gs_col_offset(p) + do i=1,chunks(cid)%ncols + curgcol = curgcol + 1 + pgcols(curgcol)%chunk = cid + pgcols(curgcol)%ccol = i + enddo + gs_col_offset(p) = curgcol + enddo + + ! Reinitialize pchunkid and gs_col_offset (for real) + pchunkid(0) = 1 + gs_col_offset(0) = 1 + do p=1,npes-1 + pchunkid(p) = pchunkid(p-1) + npchunks(p-1) + gs_col_offset(p) = gs_col_offset(p-1) + gs_col_num(p-1) + enddo + pchunkid(npes) = pchunkid(npes-1) + npchunks(npes-1) + gs_col_offset(npes) = gs_col_offset(npes-1) + gs_col_num(npes-1) + + ! Save local information + ! (Local chunk index range chosen so that it does not overlap + ! {begblock,...,endblock}) + ! + nlcols = gs_col_num(iam) + nlchunks = npchunks(iam) + begchunk = pchunkid(iam) + lastblock + endchunk = pchunkid(iam+1) + lastblock - 1 + ! + allocate( lchunks(begchunk:endchunk) ) + do cid=1,nchunks + if (chunks(cid)%owner == iam) then + lcid = chunks(cid)%lcid + lchunks(lcid)%ncols = chunks(cid)%ncols + lchunks(lcid)%cid = cid + do i=1,chunks(cid)%ncols + lchunks(lcid)%gcol(i) = chunks(cid)%gcol(i) + enddo + endif + enddo + + deallocate( pchunkid ) + deallocate( npchunks ) + ! + !----------------------------------------------------------------------- + ! + ! Initialize physics grid, using dynamics grid + ! b) column area and integration weight + + allocate( area_d(1:ngcols) ) + allocate( wght_d(1:ngcols) ) + area_d = 0.0_r8 + wght_d = 0.0_r8 + + call get_horiz_grid_d(ngcols, area_d_out=area_d, wght_d_out=wght_d) + + + if ( abs(sum(area_d) - 4.0_r8*pi) > 1.e-10_r8 ) then + write(iulog,*) ' ERROR: sum of areas on globe does not equal 4*pi' + write(iulog,*) ' sum of areas = ', sum(area_d), sum(area_d)-4.0_r8*pi + call endrun('phys_grid') + end if + + if ( abs(sum(wght_d) - 4.0_r8*pi) > 1.e-10_r8 ) then + write(iulog,*) ' ERROR: sum of integration weights on globe does not equal 4*pi' + write(iulog,*) ' sum of weights = ', sum(wght_d), sum(wght_d)-4.0_r8*pi + call endrun('phys_grid') + end if + + do lcid=begchunk,endchunk + do i=1,lchunks(lcid)%ncols + lchunks(lcid)%area(i) = area_d(lchunks(lcid)%gcol(i)) + lchunks(lcid)%wght(i) = wght_d(lchunks(lcid)%gcol(i)) + enddo + enddo + + deallocate( area_d ) + nullify(area_d) + deallocate( wght_d ) + + if (.not. local_dp_map) then + ! + ! allocate and initialize data structures for transposes + ! + allocate( btofc_blk_num(0:npes-1) ) + btofc_blk_num = 0 + allocate( btofc_blk_offset(firstblock:lastblock) ) + do jb = firstblock,lastblock + nullify( btofc_blk_offset(jb)%pter ) + enddo + ! + glbcnt = 0 + curcnt = 0 + curp = 0 + do curgcol=1,num_global_phys_cols + cid = pgcols(curgcol)%chunk + i = pgcols(curgcol)%ccol + owner_p = chunks(cid)%owner + do while (curp < owner_p) + btofc_blk_num(curp) = curcnt + curcnt = 0 + curp = curp + 1 + enddo + curgcol_d = chunks(cid)%gcol(i) + block_cnt = get_gcol_block_cnt_d(curgcol_d) + call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) + do jb = 1,block_cnt + owner_d = get_block_owner_d(blockids(jb)) + if (iam == owner_d) then + if (.not. associated(btofc_blk_offset(blockids(jb))%pter)) then + blksiz = get_block_gcol_cnt_d(blockids(jb)) + numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb)) + btofc_blk_offset(blockids(jb))%ncols = blksiz + btofc_blk_offset(blockids(jb))%nlvls = numlvl + allocate( btofc_blk_offset(blockids(jb))%pter(blksiz,numlvl) ) + endif + do k=1,btofc_blk_offset(blockids(jb))%nlvls + btofc_blk_offset(blockids(jb))%pter(bcids(jb),k) = glbcnt + curcnt = curcnt + 1 + glbcnt = glbcnt + 1 + enddo + endif + enddo + enddo + btofc_blk_num(curp) = curcnt + block_buf_nrecs = glbcnt + ! + allocate( btofc_chk_num(0:npes-1) ) + btofc_chk_num = 0 + allocate( btofc_chk_offset(begchunk:endchunk) ) + do lcid=begchunk,endchunk + ncols = lchunks(lcid)%ncols + btofc_chk_offset(lcid)%ncols = ncols + btofc_chk_offset(lcid)%nlvls = pver+1 + allocate( btofc_chk_offset(lcid)%pter(ncols,pver+1) ) + enddo + ! + curcnt = 0 + glbcnt = 0 + do p=0,npes-1 + do curgcol=gs_col_offset(iam),gs_col_offset(iam+1)-1 + cid = pgcols(curgcol)%chunk + owner_p = chunks(cid)%owner + if (iam == owner_p) then + i = pgcols(curgcol)%ccol + lcid = chunks(cid)%lcid + curgcol_d = chunks(cid)%gcol(i) + block_cnt = get_gcol_block_cnt_d(curgcol_d) + call get_gcol_block_d(curgcol_d,block_cnt,blockids,bcids) + do jb = 1,block_cnt + owner_d = get_block_owner_d(blockids(jb)) + if (p == owner_d) then + numlvl = get_block_lvl_cnt_d(blockids(jb),bcids(jb)) + call get_block_levels_d(blockids(jb),bcids(jb),numlvl,levels) + do k=1,numlvl + btofc_chk_offset(lcid)%pter(i,levels(k)+1) = glbcnt + curcnt = curcnt + 1 + glbcnt = glbcnt + 1 + enddo + endif + enddo + endif + enddo + btofc_chk_num(p) = curcnt + curcnt = 0 + enddo + chunk_buf_nrecs = glbcnt + ! + ! Precompute swap partners and number of steps in point-to-point + ! implementations of alltoall algorithm. + ! First, determine number of swaps. + ! + dp_coup_steps = 0 + do i=1,ceil2(npes)-1 + p = pair(npes,i,iam) + if (p >= 0) then + if ((btofc_blk_num(p) > 0 .or. btofc_chk_num(p) > 0)) then + dp_coup_steps = dp_coup_steps + 1 + end if + end if + end do + ! + ! Second, determine swap partners. + ! + allocate( dp_coup_proc(dp_coup_steps) ) + dp_coup_steps = 0 + do i=1,ceil2(npes)-1 + p = pair(npes,i,iam) + if (p >= 0) then + if ((btofc_blk_num(p) > 0 .or. btofc_chk_num(p) > 0)) then + dp_coup_steps = dp_coup_steps + 1 + dp_coup_proc(dp_coup_steps) = p + end if + end if + end do + ! + endif + + ! Final clean-up + deallocate( gs_col_offset ) + ! (if eliminate get_lon_xxx, can also deallocate + ! clat_p_idx, and grid_latlon?)) + + ! Add physics-package grid to set of CAM grids + ! physgrid always uses 'lat' and 'lon' as coordinate names; If dynamics + ! grid is different, it will use different coordinate names + + ! First, create a map for the physics grid + ! It's structure will depend on whether or not the physics grid is + ! unstructured + unstructured = dycore_is('UNSTRUCTURED') + if (unstructured) then + allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) + else + allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) + end if + grid_map = 0 + allocate(latvals(size(grid_map, 2))) + allocate(lonvals(size(grid_map, 2))) + p = 0 + do lcid = begchunk, endchunk + ncols = lchunks(lcid)%ncols + call get_gcol_all_p(lcid, pcols, gcols) + ! collect latvals and lonvals + cid = lchunks(lcid)%cid + do i = 1, chunks(cid)%ncols + latvals(p + i) = latdeg_p(chunks(cid)%lat(i)) + lonvals(p + i) = londeg_p(chunks(cid)%lon(i)) + end do + if (pcols > ncols) then + ! Need to set these to detect unused columns + latvals(p+ncols+1:p+pcols) = 1000.0_r8 + lonvals(p+ncols+1:p+pcols) = 1000.0_r8 + end if - interface get_dyn_col_p - module procedure :: get_dyn_col_p_chunk - module procedure :: get_dyn_col_p_index - end interface get_dyn_col_p + ! Set grid values for this chunk + do i = 1, pcols + p = p + 1 + grid_map(1, p) = i + grid_map(2, p) = lcid + if ((i <= ncols) .and. (gcols(i) > 0)) then + if (unstructured) then + grid_map(3, p) = gcols(i) + else + grid_map(3, p) = get_lon_p(lcid, i) + grid_map(4, p) = get_lat_p(lcid, i) + end if + else + if (i <= ncols) then + call endrun("phys_grid_init: unmapped column") + end if + end if + end do + end do + + ! Note that if the dycore is using the same points as the physics grid, + ! it will have already set up 'lat' and 'lon' axes for the physics grid + ! However, these will be in the dynamics decomposition + if (unstructured) then + lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & + 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & + map=grid_map(3,:)) + lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & + 'latitude', 'degrees_north', 1, size(latvals), latvals, & + map=grid_map(3,:)) + else + + allocate(coord_map(size(grid_map, 2))) + + ! Create a lon coord map which only writes from one of each unique lon + where(latvals == latmin) + coord_map(:) = grid_map(3, :) + elsewhere + coord_map(:) = 0_iMap + end where + lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, 'longitude', & + 'degrees_east', 1, size(lonvals), lonvals, map=coord_map) + + ! Create a lat coord map which only writes from one of each unique lat + where(lonvals == lonmin) + coord_map(:) = grid_map(4, :) + elsewhere + coord_map(:) = 0_iMap + end where + lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, 'latitude', & + 'degrees_north', 1, size(latvals), latvals, map=coord_map) + + deallocate(coord_map) + + end if + call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & + grid_map, unstruct=unstructured, block_indexed=.true.) + ! Copy required attributes from the dynamics array + nullify(copy_attributes) + call physgrid_copy_attributes_d(copy_gridname, copy_attributes) + do i = 1, size(copy_attributes) + call cam_grid_attribute_copy(copy_gridname, 'physgrid', copy_attributes(i)) + end do + if ((.not. cam_grid_attr_exists('physgrid', 'area')) .and. unstructured) then + ! Physgrid always needs an area attribute. If we did not inherit one + ! from the dycore (i.e., physics and dynamics are on different grids), + ! create that attribute here (unstructured grids only, physgrid is + ! not supported for structured grids). + allocate(area_d(size(grid_map, 2))) + allocate(areawt_d(size(grid_map, 2))) + p = 0 + do lcid = begchunk, endchunk + ncols = lchunks(lcid)%ncols + call get_gcol_all_p(lcid, pcols, gcols) + ! collect latvals and lonvals + cid = lchunks(lcid)%cid + do i = 1, chunks(cid)%ncols + area_d(p + i) = lchunks(lcid)%area(i) + areawt_d(p + i) = lchunks(lcid)%wght(i) + end do + if (pcols > ncols) then + ! Need to set these to detect unused columns + area_d(p+ncols+1:p+pcols) = 0.0_r8 + areawt_d(p+ncols+1:p+pcols) = 0.0_r8 + end if + p = p + pcols + end do + call cam_grid_attribute_register('physgrid', 'area', & + 'physics column areas', 'ncol', area_d, map=grid_map(3,:)) + call cam_grid_attribute_register('physgrid', 'areawt', & + 'physics column area wts', 'ncol', areawt_d, map=grid_map(3,:)) + nullify(area_d) ! Belongs to attribute now + nullify(areawt_d) ! Belongs to attribute now + end if + ! Cleanup pointers (they belong to the grid now) + nullify(grid_map) + deallocate(latvals) + nullify(latvals) + deallocate(lonvals) + nullify(lonvals) + ! Cleanup, we are responsible for copy attributes + if (associated(copy_attributes)) then + deallocate(copy_attributes) + nullify(copy_attributes) + end if + + ! + physgrid_set = .true. ! Set flag indicating physics grid is now set + ! + call t_stopf("phys_grid_init") + + if (calc_memory_increase) then + call shr_mem_getusage(mem_hw_end, mem_end) + clat_p_tmp = mem_end - mem_beg + call MPI_reduce(clat_p_tmp, mem_end, 1, MPI_REAL8, MPI_MAX, & + masterprocid, mpicom, curp) + if (masterproc) then + write(iulog, *) 'phys_grid_init: Increase in memory usage = ', & + mem_end, ' (MB)' + end if + clat_p_tmp = mem_hw_end - mem_hw_beg + call MPI_reduce(clat_p_tmp, mem_hw_end, 1, MPI_REAL8, MPI_MAX, & + masterprocid, mpicom, curp) + if (masterproc) then + write(iulog, *) 'phys_grid_init: Increase in memory highwater = ', & + mem_end, ' (MB)' + end if + end if + + end subroutine phys_grid_init + +!======================================================================== + +subroutine phys_grid_find_col(lat, lon, owner, lcid, icol) + + !----------------------------------------------------------------------- + ! + ! Purpose: Find the global column closest to the point specified by lat + ! and lon. Return indices of owning process, local chunk, and + ! column. + ! + ! Authors: Phil Rasch / Patrick Worley / B. Eaton + ! + !----------------------------------------------------------------------- + + real(r8), intent(in) :: lat, lon ! requested location in degrees + integer, intent(out) :: owner ! rank of chunk owner + integer, intent(out) :: lcid ! local chunk index + integer, intent(out) :: icol ! column index within the chunk + + ! local + real(r8) dist2 ! the distance (in radians**2 from lat, lon) + real(r8) distmin ! the distance (in radians**2 from closest column) + real(r8) latr, lonr ! lat, lon (in radians) of requested location + real(r8) clat, clon ! lat, lon (in radians) of column being tested + real(r8) const + + integer i + integer cid + !----------------------------------------------------------------------- + + ! Check that input lat and lon are in valid range + if (lon < 0.0_r8 .or. lon >= 360._r8 .or. & + lat < -90._r8 .or. lat > 90._r8) then + if (masterproc) then + write(iulog,*) & + 'phys_grid_find_col: ERROR: lon must satisfy 0.<=lon<360. and lat must satisfy -90<=lat<=90.' + write(iulog,*) & + 'input lon=', lon, ' input lat=', lat + endif + call endrun('phys_grid_find_col: input ERROR') + end if + + const = 180._r8/pi ! degrees per radian + latr = lat/const ! to radians + lonr = lon/const ! to radians + + owner = -999 + lcid = -999 + icol = -999 + distmin = 1.e10_r8 + + ! scan all chunks for closest point to lat, lon + do cid = 1, nchunks + do i = 1, chunks(cid)%ncols + clat = clat_p(chunks(cid)%lat(i)) + clon = clon_p(chunks(cid)%lon(i)) + dist2 = (clat-latr)**2 + (clon-lonr)**2 + if (dist2 < distmin ) then + distmin = dist2 + owner = chunks(cid)%owner + lcid = chunks(cid)%lcid + icol = i + endif + enddo + end do + +end subroutine phys_grid_find_col + +!======================================================================== + +subroutine phys_grid_find_cols(lat, lon, nclosest, owner, lcid, icol, distmin, mlats, mlons) + + !----------------------------------------------------------------------- + ! + ! Purpose: Find the global columns closest to the point specified by lat + ! and lon. Return indices of owning process, local chunk, and + ! column. + ! + ! Authors: Phil Rasch / Patrick Worley / B. Eaton + ! + !----------------------------------------------------------------------- + use physconst, only : rearth + + real(r8), intent(in) :: lat, lon ! requested location in degrees + integer, intent(in) :: nclosest ! number of closest points to find + integer, intent(out) :: owner(nclosest) ! rank of chunk owner + integer, intent(out) :: lcid(nclosest) ! local chunk index + integer, intent(out) :: icol(nclosest) ! column index within the chunk + real(r8),intent(out) :: distmin(nclosest) ! the distance (m) of the closest column(s) + real(r8),intent(out) :: mlats(nclosest) ! the latitude of the closest column(s) + real(r8),intent(out) :: mlons(nclosest) ! the longitude of the closest column(s) + + ! local + real(r8) dist2 ! the distance (in radians**2 from lat, lon) + real(r8) latr, lonr ! lat, lon (in radians) of requested location + real(r8) clat, clon ! lat, lon (in radians) of column being tested + real(r8) const + + integer i, j + integer cid + !----------------------------------------------------------------------- + + ! Check that input lat and lon are in valid range + if (lon < 0.0_r8 .or. lon >= 360._r8 .or. & + lat < -90._r8 .or. lat > 90._r8) then + if (masterproc) then + write(iulog,*) & + 'phys_grid_find_cols: ERROR: lon must satisfy 0.<=lon<360. and lat must satisfy -90<=lat<=90.' + write(iulog,*) & + 'input lon=', lon, ' input lat=', lat + endif + call endrun('phys_grid_find_cols: input ERROR') + end if + + const = 180._r8/pi ! degrees per radian + latr = lat/const ! to radians + lonr = lon/const ! to radians + + owner(:) = -999 + lcid(:) = -999 + icol(:) = -999 + mlats(:) = -999 + mlons(:) = -999 + distmin(:) = 1.e10_r8 + + ! scan all chunks for closest point to lat, lon + do cid = 1, nchunks + do i = 1, chunks(cid)%ncols + clat = clat_p(chunks(cid)%lat(i)) + clon = clon_p(chunks(cid)%lon(i)) + dist2 = acos(sin(latr) * sin(clat) + cos(latr) * cos(clat) * cos(clon - lonr)) * rearth + + do j = nclosest, 1, -1 + if (dist2 < distmin(j)) then + + if (j < nclosest) then + distmin(j+1) = distmin(j) + owner(j+1) = owner(j) + lcid(j+1) = lcid(j) + icol(j+1) = icol(j) + mlats(j+1) = mlats(j) + mlons(j+1) = mlons(j) + end if - ! Private interfaces - private :: chunk_info_to_index_p + distmin(j) = dist2 + owner(j) = chunks(cid)%owner + lcid(j) = chunks(cid)%lcid + icol(j) = i + mlats(j) = clat * const + mlons(j) = clon * const + else + exit + end if + enddo + enddo + end do -!!XXgoldyXX: v temporary interface to allow old code to compile - interface get_lat_all_p - module procedure :: get_lat_all_p_r8 ! The new version - module procedure :: get_lat_all_p_int ! calls endun - end interface get_lat_all_p +end subroutine phys_grid_find_cols +! +!======================================================================== - interface get_lon_all_p - module procedure :: get_lon_all_p_r8 ! The new version - module procedure :: get_lon_all_p_int ! calls endun - end interface get_lon_all_p -!!XXgoldyXX: ^ temporary interface to allow old code to compile +logical function phys_grid_initialized () +!----------------------------------------------------------------------- +! +! Purpose: Identify whether phys_grid has been called yet or not +! +! Method: Return physgrid_set +! +! Author: Pat Worley +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! + phys_grid_initialized = physgrid_set +! + return + end function phys_grid_initialized +! +!======================================================================== +! + subroutine get_chunk_indices_p(index_beg, index_end) +!----------------------------------------------------------------------- +! +! Purpose: Return range of indices for local chunks +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(out) :: index_beg ! first index used for local chunks + integer, intent(out) :: index_end ! last index used for local chunks +!----------------------------------------------------------------------- - integer, protected, public :: pver = 0 - integer, protected, public :: pverp = 0 - integer, protected, public :: num_global_phys_cols = 0 - integer, protected, public :: columns_on_task = 0 - integer, protected, public :: index_top_layer = 0 - integer, protected, public :: index_bottom_layer = 0 - integer, protected, public :: index_top_interface = 1 - integer, protected, public :: index_bottom_interface = 0 - integer, public :: phys_columns_on_task = 0 + index_beg = begchunk + index_end = endchunk -!============================================================================== -CONTAINS -!============================================================================== + return + end subroutine get_chunk_indices_p +! +!======================================================================== +! + subroutine get_gcol_all_p(lcid, latdim, gcols) +!----------------------------------------------------------------------- +! +! Purpose: Return all global column indices for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: latdim ! declared size of output array + + integer, intent(out) :: gcols(:) ! array of global latitude indices +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + +!----------------------------------------------------------------------- + gcols=-1 + do i=1,lchunks(lcid)%ncols + gcols(i) = lchunks(lcid)%gcol(i) + enddo + return + end subroutine get_gcol_all_p - subroutine phys_grid_readnl(nlfile) - use cam_abortutils, only: endrun - use namelist_utils, only: find_group_name - use cam_logfile, only: iulog - use spmd_utils, only: mpicom, mstrid=>masterprocid, masterproc - use spmd_utils, only: mpi_integer - use ppgrid, only: pcols +! +!======================================================================== +! + integer function get_gcol_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return global physics column index for chunk column +! +! Method: +! +! Author: Jim Edwards / Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - character(len=*), intent(in) :: nlfile +!----------------------------------------------------------------------- + get_gcol_p = lchunks(lcid)%gcol(col) - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: sub = 'phys_grid_readnl' + return + end function get_gcol_p - integer :: phys_alltoall = -HUGE(1) - integer :: phys_loadbalance = -HUGE(1) - integer :: phys_twin_algorithm = -HUGE(1) - integer :: phys_chnk_per_thd = -HUGE(1) +! +!======================================================================== - namelist /phys_grid_nl/ phys_alltoall, phys_loadbalance, & - phys_twin_algorithm, phys_chnk_per_thd - !------------------------------------------------------------------------ + subroutine get_gcol_vec_p(lcid, lth, cols, gcols) +!----------------------------------------------------------------------- +! +! Purpose: Return global physics column indices for set of chunk columns +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid - ! Read namelist - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old') - call find_group_name(unitn, 'phys_grid_nl', status=ierr) - if (ierr == 0) then - read(unitn, phys_grid_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub//': FATAL: reading namelist') - end if - end if - close(unitn) - end if +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: lth ! number of column indices + integer, intent(in) :: cols(lth) ! column indices - call mpi_bcast(phys_alltoall, 1, mpi_integer, mstrid, mpicom, ierr) - call mpi_bcast(phys_loadbalance, 1, mpi_integer, mstrid, mpicom, ierr) - call mpi_bcast(phys_twin_algorithm, 1, mpi_integer, mstrid, mpicom, ierr) - call mpi_bcast(phys_chnk_per_thd, 1, mpi_integer, mstrid, mpicom, ierr) + integer, intent(out) :: gcols(lth) ! array of global physics + ! columns indices - if (masterproc) then - write(iulog,*) 'PHYS_GRID options:' - write(iulog,*) ' Using PCOLS =', pcols - write(iulog,*) ' phys_loadbalance = (not used)' - write(iulog,*) ' phys_twin_algorithm = (not used)' - write(iulog,*) ' phys_alltoall = (not used)' - write(iulog,*) ' chunks_per_thread = (not used)' - end if +!---------------------------Local workspace----------------------------- + integer :: i ! loop index - end subroutine phys_grid_readnl - - !======================================================================== - - subroutine phys_grid_init() - use mpi, only: MPI_INTEGER, MPI_REAL8, MPI_MIN, MPI_MAX - use shr_mem_mod, only: shr_mem_getusage - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use spmd_utils, only: npes, mpicom, masterprocid, masterproc, iam - use ppgrid, only: pcols - use dyn_grid, only: get_dyn_grid_info, physgrid_copy_attributes_d - use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register - use cam_grid_support, only: iMap, hclen => max_hcoordname_len - use cam_grid_support, only: horiz_coord_t, horiz_coord_create - use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists - use shr_const_mod, only: PI => SHR_CONST_PI - use scamMod, only: scmlon,scmlat,single_column - - ! Local variables - integer :: index - integer :: col_index, phys_col - integer :: ichnk, icol, ncol, gcol - integer :: num_chunks - type(physics_column_t), allocatable :: dyn_columns(:) ! Dyn decomp - ! Maps and values for physics grid - real(r8), pointer :: lonvals(:) - real(r8), pointer :: latvals(:) - real(r8) :: lonmin, latmin - integer(iMap), pointer :: grid_map(:,:) - integer(iMap), allocatable :: coord_map(:) - type(horiz_coord_t), pointer :: lat_coord - type(horiz_coord_t), pointer :: lon_coord - real(r8), pointer :: area_d(:) - real(r8), pointer :: areawt_d(:) - real(r8) :: mem_hw_beg, mem_hw_end - real(r8) :: mem_beg, mem_end - logical :: unstructured - real(r8) :: temp ! For MPI - integer :: ierr ! For MPI - character(len=hclen), pointer :: copy_attributes(:) - character(len=hclen) :: copy_gridname - character(len=*), parameter :: subname = 'phys_grid_init: ' - real(r8), parameter :: rarea_sphere = 1.0_r8 / (4.0_r8*PI) - real (r8), allocatable :: dynlats(:),dynlons(:),pos_dynlons(:) - real (r8) :: pos_scmlon,minpoint,testpoint - integer :: scm_col_index, i - - nullify(lonvals) - nullify(latvals) - nullify(grid_map) - nullify(lat_coord) - nullify(lon_coord) - nullify(area_d) - nullify(areawt_d) - nullify(copy_attributes) +!----------------------------------------------------------------------- + do i=1,lth + gcols(i) = lchunks(lcid)%gcol(cols(i)) + enddo - if (calc_memory_increase) then - call shr_mem_getusage(mem_hw_beg, mem_beg) - end if + return + end subroutine get_gcol_vec_p - call t_adj_detailf(-2) - call t_startf("phys_grid_init") +! +!======================================================================== +! + integer function get_ncols_p(lcid) +!----------------------------------------------------------------------- +! +! Purpose: Return number of columns in chunk given the local chunk id. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id - ! Gather info from the dycore - call get_dyn_grid_info(hdim1_d, hdim2_d, pver, index_top_layer, & - index_bottom_layer, unstructured, dyn_columns) +!---------------------------Local workspace----------------------------- + integer :: cid ! global chunk id - ! Set up the physics decomposition - columns_on_task = size(dyn_columns) +!----------------------------------------------------------------------- + get_ncols_p = lchunks(lcid)%ncols - if (single_column) then - allocate(dynlats(columns_on_task),dynlons(columns_on_task),pos_dynlons(columns_on_task)) - dynlats(:) = dyn_columns(:)%lat_deg - dynlons(:) = dyn_columns(:)%lon_deg + return + end function get_ncols_p - pos_dynlons(:)= mod(dynlons(:) + 360._r8,360._r8) - pos_scmlon = mod(scmlon + 360._r8,360._r8) +!======================================================================== - if (unstructured) then - minpoint=1000.0 - do i=1,columns_on_task - testpoint=abs(pos_dynlons(i)-pos_scmlon)+abs(dynlats(i)-scmlat) - if (testpoint .lt. minpoint) then - minpoint=testpoint - scm_col_index=i - endif - enddo - else -!jt start(1) = (MINLOC(abs(pos_lons-pos_scmlon),dim=1)) -!jt start(2) = (MINLOC(abs(lats -scmlat ),dim=1)) - end if - hdim1_d = 1 - hdim2_d = 1 - phys_columns_on_task = 1 - deallocate(dynlats,dynlons,pos_dynlons) - else - phys_columns_on_task = columns_on_task - end if - ! hdim1_d * hdim2_d is the total number of columns - num_global_phys_cols = hdim1_d * hdim2_d - pverp = pver + 1 - !!XXgoldyXX: Can we enforce interface numbering separate from dycore? - !!XXgoldyXX: This will work for both CAM and WRF/MPAS physics - !!XXgoldyXX: This only has a 50% chance of working on a single level model - if (index_top_layer < index_bottom_layer) then - index_top_interface = index_top_layer - index_bottom_interface = index_bottom_layer + 1 - else - index_bottom_interface = index_bottom_layer - index_top_interface = index_top_layer + 1 - end if + subroutine get_grid_dims(hdim1_d_out, hdim2_d_out) + use cam_abortutils, only: endrun + ! retrieve dynamics field grid information + ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid + ! data structure, If 1D data structure, then hdim2_d == 1. + integer, intent(out) :: hdim1_d_out + integer, intent(out) :: hdim2_d_out - if (allocated(phys_columns)) then - deallocate(phys_columns) - end if - allocate(phys_columns(phys_columns_on_task)) - if (phys_columns_on_task > 0) then - col_index = phys_columns_on_task - num_chunks = col_index / pcols - if ((num_chunks * pcols) < col_index) then - num_chunks = num_chunks + 1 - end if - begchunk = 1 - endchunk = begchunk + num_chunks - 1 - else - ! We do not support tasks with no physics columns - call endrun(subname//'No columns on task, use fewer tasks') + if (.not. phys_grid_initialized()) then + call endrun('get_grid_dims: physics grid not initialized') end if - allocate(chunks(begchunk:endchunk)) - col_index = 0 - ! Simple chunk assignment - do index = begchunk, endchunk - chunks(index)%ncols = MIN(pcols, (phys_columns_on_task - col_index)) - chunks(index)%chunk_index = index - allocate(chunks(index)%phys_cols(chunks(index)%ncols)) - do phys_col = 1, chunks(index)%ncols - col_index = col_index + 1 - ! Copy information supplied by the dycore - if (single_column) then - phys_columns(col_index) = dyn_columns(scm_col_index) -!jt !scm physics only has 1 global column -!jt phys_columns(col_index)%global_col_num = 1 - else - phys_columns(col_index) = dyn_columns(col_index) - end if - ! Fill in physics decomp info - phys_columns(col_index)%coord_indicies(:)=scm_col_index - phys_columns(col_index)%phys_task = iam - phys_columns(col_index)%local_phys_chunk = index - phys_columns(col_index)%phys_chunk_index = phys_col - chunks(index)%phys_cols(phys_col) = col_index - end do - end do + hdim1_d_out = hdim1_d + hdim2_d_out = hdim2_d - deallocate(dyn_columns) + end subroutine get_grid_dims +! +!======================================================================== +! + subroutine get_lat_all_p(lcid, latdim, lats) +!----------------------------------------------------------------------- +! +! Purpose: Return all global latitude indices for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: latdim ! declared size of output array + + integer, intent(out) :: lats(latdim) ! array of global latitude indices + +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,chunks(cid)%ncols + lats(i) = chunks(cid)%lat(i) + enddo + + return + end subroutine get_lat_all_p +! +!======================================================================== - ! Add physics-package grid to set of CAM grids - ! physgrid always uses 'lat' and 'lon' as coordinate names; If dynamics - ! grid is different, it will use different coordinate names + subroutine get_lat_vec_p(lcid, lth, cols, lats) +!----------------------------------------------------------------------- +! +! Purpose: Return global latitude indices for set of chunk columns +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid - ! First, create a map for the physics grid - ! It's structure will depend on whether or not the physics grid is - ! unstructured - if (unstructured) then - allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) - else - allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) - end if - grid_map = 0_iMap - allocate(latvals(size(grid_map, 2))) - allocate(lonvals(size(grid_map, 2))) - - lonmin = 1000.0_r8 ! Out of longitude range - latmin = 1000.0_r8 ! Out of latitude range - index = 0 - do ichnk = begchunk, endchunk - ncol = chunks(ichnk)%ncols ! Too soon to call get_ncols_p - do icol = 1, pcols - index = index + 1 - if (icol <= ncol) then - col_index = chunks(ichnk)%phys_cols(icol) - latvals(index) = phys_columns(col_index)%lat_deg - if (latvals(index) < latmin) then - latmin = latvals(index) - end if - lonvals(index) = phys_columns(col_index)%lon_deg - if (lonvals(index) < lonmin) then - lonmin = lonvals(index) - end if - else - col_index = -1 - latvals(index) = 1000.0_r8 - lonvals(index) = 1000.0_r8 - end if - grid_map(1, index) = int(icol, iMap) - grid_map(2, index) = int(ichnk, iMap) - if (icol <= ncol) then - if (unstructured) then - gcol = phys_columns%(col_index)%global_col_num - if (gcol > 0) then - grid_map(3, index) = int(gcol, iMap) - end if ! else entry remains 0 - else - ! lon - gcol = phys_columns(col_index)%coord_indices(1) - if (gcol > 0) then - grid_map(3, index) = int(gcol, iMap) - end if ! else entry remains 0 - ! lat - gcol = phys_columns(col_index)%coord_indices(2) - if (gcol > 0) then - grid_map(4, index) = gcol - end if ! else entry remains 0 - end if - end if ! Else entry remains 0 - end do - end do +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: lth ! number of column indices + integer, intent(in) :: cols(lth) ! column indices - ! Note that if the dycore is using the same points as the physics grid, - ! it will have already set up 'lat' and 'lon' axes for - ! the physics grid - ! However, these will be in the dynamics decomposition - - if (unstructured) then - lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & - 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & - map=grid_map(3,:)) - lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & - 'latitude', 'degrees_north', 1, size(latvals), latvals, & - map=grid_map(3,:)) - else - allocate(coord_map(size(grid_map, 2))) - ! We need a global minimum longitude and latitude - if (npes > 1) then - temp = lonmin - call MPI_allreduce(temp, lonmin, 1, MPI_INTEGER, MPI_MIN, & - mpicom, ierr) - temp = latmin - call MPI_allreduce(temp, latmin, 1, MPI_INTEGER, MPI_MIN, & - mpicom, ierr) - ! Create lon coord map which only writes from one of each unique lon - where(latvals == latmin) - coord_map(:) = grid_map(3, :) - elsewhere - coord_map(:) = 0_iMap - end where - lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, & - 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & - map=coord_map) - - ! Create lat coord map which only writes from one of each unique lat - where(lonvals == lonmin) - coord_map(:) = grid_map(4, :) - elsewhere - coord_map(:) = 0_iMap - end where - lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, & - 'latitude', 'degrees_north', 1, size(latvals), latvals, & - map=coord_map) - deallocate(coord_map) - end if - end if - call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & - grid_map, unstruct=unstructured, block_indexed=.true.) - ! Copy required attributes from the dynamics array - nullify(copy_attributes) - call physgrid_copy_attributes_d(copy_gridname, copy_attributes) - do index = 1, size(copy_attributes) - call cam_grid_attribute_copy(copy_gridname, 'physgrid', & - copy_attributes(index)) - end do + integer, intent(out) :: lats(lth) ! array of global latitude indices - if (.not. cam_grid_attr_exists('physgrid', 'area')) then - ! Physgrid always needs an area attribute. - if (unstructured) then - ! If we did not inherit one from the dycore (i.e., physics and - ! dynamics are on different grids), create that attribute here - ! (Note, a separate physics grid is only supported for - ! unstructured grids). - allocate(area_d(size(grid_map, 2))) - do col_index = 1, phys_columns_on_task - area_d(col_index) = phys_columns(col_index)%area - end do - call cam_grid_attribute_register('physgrid', 'area', & - 'physics column areas', 'ncol', area_d, map=grid_map(3,:)) - nullify(area_d) ! Belongs to attribute now +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id - allocate(areawt_d(size(grid_map, 2))) - do col_index = 1, phys_columns_on_task - areawt_d(col_index) = phys_columns(col_index)%weight*rarea_sphere - end do - call cam_grid_attribute_register('physgrid', 'areawt', & - 'physics column area weight', 'ncol', areawt_d, map=grid_map(3,:)) - nullify(areawt_d) ! Belongs to attribute now - else - call endrun(subname//"No 'area' attribute from dycore") - end if - end if - ! Cleanup pointers (they belong to the grid now) - nullify(grid_map) - deallocate(latvals) - nullify(latvals) - deallocate(lonvals) - nullify(lonvals) - ! Cleanup, we are responsible for copy attributes - if (associated(copy_attributes)) then - deallocate(copy_attributes) - nullify(copy_attributes) - end if +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,lth + lats(i) = chunks(cid)%lat(cols(i)) + enddo - ! Set flag indicating physics grid is now set - phys_grid_set = .true. + return + end subroutine get_lat_vec_p +! +!======================================================================== - call t_stopf("phys_grid_init") - call t_adj_detailf(+2) + integer function get_lat_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return global latitude index for chunk column +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - if (calc_memory_increase) then - call shr_mem_getusage(mem_hw_end, mem_end) - temp = mem_end - mem_beg - call MPI_reduce(temp, mem_end, 1, MPI_REAL8, MPI_MAX, masterprocid, & - mpicom, ierr) - if (masterproc) then - write(iulog, *) 'phys_grid_init: Increase in memory usage = ', & - mem_end, ' (MB)' - end if - temp = mem_hw_end - mem_hw_beg - call MPI_reduce(temp, mem_hw_end, 1, MPI_REAL8, MPI_MAX, & - masterprocid, mpicom, ierr) - if (masterproc) then - write(iulog, *) subname, 'Increase in memory highwater = ', & - mem_end, ' (MB)' - end if - end if +!---------------------------Local workspace----------------------------- + integer :: cid ! global chunk id - end subroutine phys_grid_init +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + get_lat_p = chunks(cid)%lat(col) - !======================================================================== + return + end function get_lat_p +! +!======================================================================== +! + subroutine get_lon_all_p(lcid, londim, lons) +!----------------------------------------------------------------------- +! +! Purpose: +! Was: Return all global longitude indices for chunk +! Now: Return all longitude offsets (+1) for chunk. These are offsets +! in ordered list of global columns from first +! column with given latitude to column with given latitude +! and longitude. This corresponds to the usual longitude indices +! for full and reduced lon/lat grids. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: londim ! declared size of output array + + integer, intent(out) :: lons(londim) ! array of global longitude + ! indices + +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: lat ! latitude index + integer :: cid ! global chunk id + integer :: gcol ! global column id in latlon + ! ordering + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,chunks(cid)%ncols + lat = chunks(cid)%lat(i) + gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(i)) + lons(i) = (gcol - clat_p_idx(lat)) + 1 + enddo + + return + end subroutine get_lon_all_p +! +!======================================================================== - integer function chunk_info_to_index_p(lcid, col, subname_in) - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - ! Return the physics column index indicated by - ! (chunk) and (column). + subroutine get_lon_vec_p(lcid, lth, cols, lons) +!----------------------------------------------------------------------- +! +! Purpose: +! Was: Return global longitude indices for set of chunk columns. +! Now: Return longitude offsets (+1) for set of chunk columns. +! These are offsets in ordered list of global columns from first +! column with given latitude to column with given latitude +! and longitude. This corresponds to the usual longitude indices +! for full and reduced lon/lat grids. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: lth ! number of column indices + integer, intent(in) :: cols(lth) ! column indices + + integer, intent(out) :: lons(lth) ! array of global longitude indices + +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: lat ! latitude index + integer :: cid ! global chunk id + integer :: gcol ! global column id in latlon + ! ordering + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,lth + lat = chunks(cid)%lat(cols(i)) + gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(i)) + lons(i) = (gcol - clat_p_idx(lat)) + 1 + enddo + + return + end subroutine get_lon_vec_p +! +!======================================================================== - ! Dummy arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! Column index - character(len=*), optional, intent(in) :: subname_in - ! Local variables - character(len=128) :: errmsg - character(len=*), parameter :: subname = 'chunk_info_to_index_p: ' + integer function get_lon_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: +! Was: Return global longitude index for chunk column. +! Now: Return longitude offset (+1) for chunk column. This is the +! offset in ordered list of global columns from first +! column with given latitude to column with given latitude +! and longitude. This corresponds to the usual longitude index +! for full and reduced lon/lat grids. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index + +!---------------------------Local workspace----------------------------- + integer :: cid ! global chunk id + integer :: lat ! latitude index + integer :: gcol ! global column id in latlon + ! ordering + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + lat = chunks(cid)%lat(col) + gcol = dyn_to_latlon_gcol_map(chunks(cid)%gcol(col)) + get_lon_p = (gcol - clat_p_idx(lat)) + 1 + + return + end function get_lon_p +! +!======================================================================== +! + subroutine get_rlat_all_p(lcid, rlatdim, rlats) +!----------------------------------------------------------------------- +! +! Purpose: Return all latitudes (in radians) for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rlatdim ! declared size of output array - if (.not. phys_grid_initialized()) then - if (present(subname_in)) then - call endrun(trim(subname_in)//'physics grid not initialized') - else - call endrun(subname//'physics grid not initialized') - end if - else if ((lcid < begchunk) .or. (lcid > endchunk)) then - if (present(subname_in)) then - write(errmsg, '(a,3(a,i0))') trim(subname_in), 'lcid (', lcid, & - ') out of range (', begchunk, ' to ', endchunk - else - write(errmsg, '(a,3(a,i0))') subname, 'lcid (', lcid, & - ') out of range (', begchunk, ' to ', endchunk - end if - write(iulog, *) trim(errmsg) - call endrun(trim(errmsg)) - else if ((col < 1) .or. (col > get_ncols_p(lcid))) then - if (present(subname_in)) then - write(errmsg, '(a,2(a,i0))') trim(subname_in), 'col (', col, & - ') out of range (1 to ', get_ncols_p(lcid) - else - write(errmsg, '(a,2(a,i0))') subname, 'col (', col, & - ') out of range (1 to ', get_ncols_p(lcid) - end if - write(iulog, *) trim(errmsg) - call endrun(trim(errmsg)) - end if - chunk_info_to_index_p = chunks(lcid)%phys_cols(col) - end function chunk_info_to_index_p + real(r8), intent(out) :: rlats(rlatdim)! array of latitudes - !======================================================================== +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id - logical function phys_grid_initialized() - ! Return .true. if the physics grid is initialized, otherwise .false. - phys_grid_initialized = phys_grid_set - end function phys_grid_initialized +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,chunks(cid)%ncols + rlats(i) = clat_p(chunks(cid)%lat(i)) + enddo - !======================================================================== + return + end subroutine get_rlat_all_p +! +!======================================================================== +! + subroutine get_area_all_p(lcid, rdim, area) +!----------------------------------------------------------------------- +! +! Purpose: Return all areas for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rdim ! declared size of output array - integer function get_nlcols_p() - get_nlcols_p = phys_columns_on_task - end function get_nlcols_p + real(r8), intent(out) :: area(rdim) ! array of areas - !======================================================================== +!---------------------------Local workspace----------------------------- + integer :: i ! loop index - real(r8) function get_rlat_p(lcid, col) - !----------------------------------------------------------------------- - ! - ! get_rlat_p: latitude of a physics column in radians - ! - !----------------------------------------------------------------------- - - ! Dummy argument - integer, intent(in) :: lcid - integer, intent(in) :: col - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_rlat_p' - - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_rlat_p = phys_columns(index)%lat_rad +!----------------------------------------------------------------------- + do i=1,lchunks(lcid)%ncols + area(i) = lchunks(lcid)%area(i) + enddo - end function get_rlat_p + return + end subroutine get_area_all_p +! +!======================================================================== +! + real(r8) function get_area_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return area for chunk column +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - !======================================================================== +!----------------------------------------------------------------------- + get_area_p = lchunks(lcid)%area(col) - real(r8) function get_rlon_p(lcid, col) - !----------------------------------------------------------------------- - ! - ! get_rlon_p: longitude of a physics column in radians - ! - !----------------------------------------------------------------------- - - ! Dummy argument - integer, intent(in) :: lcid - integer, intent(in) :: col - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_rlon_p' - - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_rlon_p = phys_columns(index)%lon_rad + return + end function get_area_p +! +!======================================================================== +! + subroutine get_wght_all_p(lcid, rdim, wght) +!----------------------------------------------------------------------- +! +! Purpose: Return all integration weights for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rdim ! declared size of output array - end function get_rlon_p + real(r8), intent(out) :: wght(rdim) ! array of integration weights - !======================================================================== +!---------------------------Local workspace----------------------------- + integer :: i ! loop index - subroutine get_rlat_all_p(lcid, rlatdim, rlats) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_rlat_all_p: Return all latitudes (in radians) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rlatdim ! declared size of output array - real(r8), intent(out) :: rlats(rlatdim) ! array of latitudes - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_rlat_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), rlatdim) - phys_ind = chunks(lcid)%phys_cols(index) - rlats(index) = phys_columns(phys_ind)%lat_rad - end do +!----------------------------------------------------------------------- + do i=1,lchunks(lcid)%ncols + wght(i) = lchunks(lcid)%wght(i) + enddo - end subroutine get_rlat_all_p + return + end subroutine get_wght_all_p +! +!======================================================================== +! + real(r8) function get_wght_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return integration weight for chunk column +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - !======================================================================== +!----------------------------------------------------------------------- + get_wght_p = lchunks(lcid)%wght(col) - subroutine get_rlon_all_p(lcid, rlondim, rlons) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_rlon_all_p:: Return all longitudes (in radians) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: rlondim ! declared size of output array - real(r8), intent(out) :: rlons(rlondim) ! array of longitudes - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_rlon_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), rlondim) - phys_ind = chunks(lcid)%phys_cols(index) - rlons(index) = phys_columns(phys_ind)%lon_rad - end do + return + end function get_wght_p +! +!======================================================================== +! + subroutine get_rlat_vec_p(lcid, lth, cols, rlats) +!----------------------------------------------------------------------- +! +! Purpose: Return latitudes (in radians) for set of chunk columns +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: lth ! number of column indices + integer, intent(in) :: cols(lth) ! column indices + + real(r8), intent(out) :: rlats(lth) ! array of latitudes + +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,lth + rlats(i) = clat_p(chunks(cid)%lat(cols(i))) + enddo + + return + end subroutine get_rlat_vec_p +! +!======================================================================== - end subroutine get_rlon_all_p + real(r8) function get_rlat_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return latitude (in radians) for chunk column +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - !======================================================================== +!---------------------------Local workspace----------------------------- + integer :: cid ! global chunk id - real(r8) function get_lat_p(lcid, col) - !----------------------------------------------------------------------- - ! - ! get_lat_p: latitude of a physics column in degrees - ! - !----------------------------------------------------------------------- +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + get_rlat_p = clat_p(chunks(cid)%lat(col)) - ! Dummy argument - integer, intent(in) :: lcid - integer, intent(in) :: col - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_lat_p' + return + end function get_rlat_p +! +!======================================================================== +! + subroutine get_rlon_all_p(lcid, rlondim, rlons) +!----------------------------------------------------------------------- +! +! Purpose: Return all longitudes (in radians) for chunk +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: rlondim ! declared size of output array - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_lat_p = phys_columns(index)%lat_deg + real(r8), intent(out) :: rlons(rlondim)! array of longitudes - end function get_lat_p +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id - !======================================================================== +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,chunks(cid)%ncols + rlons(i) = clon_p(chunks(cid)%lon(i)) + enddo - real(r8) function get_lon_p(lcid, col) - !----------------------------------------------------------------------- - ! - ! get_lon_p: longitude of a physics column in degrees - ! - !----------------------------------------------------------------------- + return + end subroutine get_rlon_all_p +! +!======================================================================== - ! Dummy argument - integer, intent(in) :: lcid - integer, intent(in) :: col - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_lon_p' + subroutine get_rlon_vec_p(lcid, lth, cols, rlons) +!----------------------------------------------------------------------- +! +! Purpose: Return longitudes (in radians) for set of chunk columns +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: lth ! number of column indices + integer, intent(in) :: cols(lth) ! column indices + + real(r8), intent(out) :: rlons(lth) ! array of longitudes + +!---------------------------Local workspace----------------------------- + integer :: i ! loop index + integer :: cid ! global chunk id + +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + do i=1,lth + rlons(i) = clon_p(chunks(cid)%lon(cols(i))) + enddo + + return + end subroutine get_rlon_vec_p +! +!======================================================================== - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_lon_p = phys_columns(index)%lon_deg + real(r8) function get_rlon_p(lcid, col) +!----------------------------------------------------------------------- +! +! Purpose: Return longitude (in radians) for chunk column +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use ppgrid +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: col ! column index - end function get_lon_p +!---------------------------Local workspace----------------------------- + integer :: cid ! global chunk id - !======================================================================== +!----------------------------------------------------------------------- + cid = lchunks(lcid)%cid + get_rlon_p = clon_p(chunks(cid)%lon(col)) - subroutine get_lat_all_p_r8(lcid, latdim, lats) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_lat_all_p: Return all latitudes (in degrees) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: latdim ! declared size of output array - real(r8), intent(out) :: lats(latdim) ! array of latitudes - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_lat_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), latdim) - phys_ind = chunks(lcid)%phys_cols(index) - lats(index) = phys_columns(phys_ind)%lat_deg + return + end function get_rlon_p +! +!======================================================================== +! + + subroutine scatter_field_to_chunk(fdim,mdim,ldim, & + hdim1d,globalfield,localchunks) +!----------------------------------------------------------------------- +! +! Purpose: Distribute field +! to decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! + +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + real(r8), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + ! global field + + real(r8), intent(out):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + ! local chunks + +!---------------------------Local workspace----------------------------- + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + real(r8) gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be scattered + real(r8) lfield_p(fdim,mdim,ldim,nlcols) + ! local component of scattered + ! vector + integer :: displs(0:npes-1) ! scatter displacements + integer :: sndcnts(0:npes-1) ! scatter send counts + integer :: recvcnt ! scatter receive count + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + write(iulog,*) __FILE__,__LINE__,hdim1d,hdim1_d + call endrun ('SCATTER_FIELD_TO_CHUNK error: hdim1d < hdim1_d') + endif + localchunks(:,:,:,:,:) = 0 +#if ( defined SPMD ) + displs(0) = 0 + sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + sndcnts(p-1) + sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + recvcnt = fdim*mdim*ldim*nlcols + + if (masterproc) then + +! copy field into global (process-ordered) chunked data structure + + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + gfield_p(f,m,l,i) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do + end do + endif + +! scatter to other processes +! (pgcols ordering consistent with begchunk:endchunk +! local ordering) + + call t_barrierf('sync_scat_ftoc', mpicom) + call mpiscatterv(gfield_p, sndcnts, displs, mpir8, & + lfield_p, recvcnt, mpir8, 0, mpicom) + +! copy into local chunked data structure + + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do l=1,ldim + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + lfield_p(f, m, l, i) + end do + end do end do + end do +#else + +! copy field into chunked data structure +! (pgcol ordering chosen to reflect begchunk:endchunk +! local ordering) + + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do + end do - end subroutine get_lat_all_p_r8 +#endif - !======================================================================== + return + end subroutine scatter_field_to_chunk +!======================================================================== - subroutine get_lon_all_p_r8(lcid, londim, lons) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_lon_all_p:: Return all longitudes (in degrees) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: londim ! declared size of output array - real(r8), intent(out) :: lons(londim) ! array of longitudes - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_lon_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), londim) - phys_ind = chunks(lcid)%phys_cols(index) - lons(index) = phys_columns(phys_ind)%lon_deg + subroutine scatter_field_to_chunk4(fdim,mdim,ldim, & + hdim1d,globalfield,localchunks) +!----------------------------------------------------------------------- +! +! Purpose: Distribute field +! to decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + real(r4), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + ! global field + + real(r4), intent(out):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + ! local chunks + +!---------------------------Local workspace----------------------------- + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + real(r4) gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be scattered + real(r4) lfield_p(fdim,mdim,ldim,nlcols) + ! local component of scattered + ! vector + integer :: displs(0:npes-1) ! scatter displacements + integer :: sndcnts(0:npes-1) ! scatter send counts + integer :: recvcnt ! scatter receive count + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + call endrun ('SCATTER_FIELD_TO_CHUNK4 error: hdim1d < hdim1_d') + endif +#if ( defined SPMD ) + displs(0) = 0 + sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + sndcnts(p-1) + sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + recvcnt = fdim*mdim*ldim*nlcols + + if (masterproc) then + ! copy field into global (process-ordered) chunked data structure + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + gfield_p(f,m,l,i) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do end do + endif + +! scatter to other processes +! (pgcols ordering consistent with begchunk:endchunk +! local ordering) + + call t_barrierf('sync_scat_ftoc', mpicom) + call mpiscatterv(gfield_p, sndcnts, displs, mpir4, & + lfield_p, recvcnt, mpir4, 0, mpicom) + +! copy into local chunked data structure + + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do l=1,ldim + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + lfield_p(f, m, l, i) + end do + end do + end do + end do +#else + + ! copy field into chunked data structure + ! (pgcol ordering chosen to reflect begchunk:endchunk + ! local ordering) + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do + end do - end subroutine get_lon_all_p_r8 +#endif - !======================================================================== + return + end subroutine scatter_field_to_chunk4 +!======================================================================== - subroutine get_area_all_p(lcid, areadim, areas) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_area_all_p: Return all areas for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: areadim ! declared size of output array - real(r8), intent(out) :: areas(areadim) ! array of areas - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_area_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), areadim) - phys_ind = chunks(lcid)%phys_cols(index) - areas(index) = phys_columns(phys_ind)%area + subroutine scatter_field_to_chunk_int(fdim,mdim,ldim, & + hdim1d,globalfield,localchunks) +!----------------------------------------------------------------------- +! +! Purpose: Distribute field +! to decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + integer, intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + ! global field + + integer, intent(out):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + ! local chunks + +!---------------------------Local workspace----------------------------- + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + integer gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be scattered + integer lfield_p(fdim,mdim,ldim,nlcols) + ! local component of scattered + ! vector + integer :: displs(0:npes-1) ! scatter displacements + integer :: sndcnts(0:npes-1) ! scatter send counts + integer :: recvcnt ! scatter receive count + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + call endrun ('SCATTER_FIELD_TO_CHUNK_INT error: hdim1d < hdim1_d') + endif +#if ( defined SPMD ) + displs(0) = 0 + sndcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + sndcnts(p-1) + sndcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + recvcnt = fdim*mdim*ldim*nlcols + + if (masterproc) then + +! copy field into global (process-ordered) chunked data structure + + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + gfield_p(f,m,l,i) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do + end do + endif + +! scatter to other processes +! (pgcols ordering consistent with begchunk:endchunk +! local ordering) + + call t_barrierf('sync_scat_ftoc', mpicom) + call mpiscatterv(gfield_p, sndcnts, displs, mpiint, & + lfield_p, recvcnt, mpiint, 0, mpicom) + +! copy into local chunked data structure + + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do l=1,ldim + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + lfield_p(f, m, l, i) + end do + end do end do + end do +#else + +! copy field into chunked data structure +! (pgcol ordering chosen to reflect begchunk:endchunk +! local ordering) + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + localchunks(f,lid,m,lcid,l) = & + globalfield(f, h1, m, h2, l) + end do + end do + end do + end do - end subroutine get_area_all_p +#endif - !======================================================================== + return + end subroutine scatter_field_to_chunk_int +! +!======================================================================== +! + subroutine gather_chunk_to_field(fdim,mdim,ldim, & + hdim1d,localchunks,globalfield) - subroutine get_wght_all_p(lcid, wghtdim, wghts) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_wght_all_p: Return all weights for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: wghtdim ! declared size of output array - real(r8), intent(out) :: wghts(wghtdim) ! array of weights - - ! Local variables - integer :: index ! loop index - integer :: phys_ind - character(len=*), parameter :: subname = 'get_wght_all_p: ' - - !----------------------------------------------------------------------- - if ((lcid < begchunk) .or. (lcid > endchunk)) then - call endrun(subname//'chunk index out of range') - end if - do index = 1, MIN(get_ncols_p(lcid, subname_in=subname), wghtdim) - phys_ind = chunks(lcid)%phys_cols(index) - wghts(index) = phys_columns(phys_ind)%weight +!----------------------------------------------------------------------- +! +! Purpose: Reconstruct field +! from decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +#if ( defined SPMD ) + use spmd_utils, only: fc_gatherv +#endif +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + real(r8), intent(in):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + ! local chunks + + real(r8), intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + ! global field + +!---------------------------Local workspace----------------------------- + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + real(r8) gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be gathered + real(r8) lfield_p(fdim,mdim,ldim,nlcols) + ! local component of gather + ! vector + integer :: displs(0:npes-1) ! gather displacements + integer :: rcvcnts(0:npes-1) ! gather receive count + integer :: sendcnt ! gather send counts + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + call endrun ('GATHER_CHUNK_TO_FIELD error: hdim1d < hdim1_d') + endif +#if ( defined SPMD ) + displs(0) = 0 + rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + rcvcnts(p-1) + rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + sendcnt = fdim*mdim*ldim*nlcols + +! copy into local gather data structure + + do l=1,ldim + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do m=1,mdim + do f=1,fdim + lfield_p(f, m, l, i) = & + localchunks(f,lid,m,lcid,l) + end do + end do + end do + end do + +! gather from other processes + + call t_barrierf('sync_gath_ctof', mpicom) + call fc_gatherv(lfield_p, sendcnt, mpir8, & + gfield_p, rcvcnts, displs, mpir8, 0, mpicom) + + if (masterproc) then + +! copy gathered columns into lon/lat field + + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do l=1,ldim + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = gfield_p(f,m,l,i) + end do + end do + end do + end do + endif + call mpibarrier(mpicom) +#else + + ! copy chunked data structure into dynamics field + ! (pgcol ordering chosen to reflect begchunk:endchunk + ! local ordering) + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = localchunks(f,lid,m,lcid,l) + end do + end do end do + end do - end subroutine get_wght_all_p +#endif - !======================================================================== + return + end subroutine gather_chunk_to_field - integer function get_ncols_p(lcid, subname_in) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_ncols_p: Return number of columns in chunk given the local chunk id. - ! - !----------------------------------------------------------------------- - ! Dummy arguments - integer, intent(in) :: lcid ! local chunk id - character(len=*), optional, intent(in) :: subname_in +! +!======================================================================== +! + subroutine gather_chunk_to_field4 (fdim,mdim,ldim, & + hdim1d,localchunks,globalfield) - if (.not. phys_grid_initialized()) then - if (present(subname_in)) then - call endrun(trim(subname_in)//'physics grid not initialized') - else - call endrun('get_ncols_p: physics grid not initialized') - end if - else - get_ncols_p = chunks(lcid)%ncols - end if +!----------------------------------------------------------------------- +! +! Purpose: Reconstruct field +! from decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +#if ( defined SPMD ) + use spmd_utils, only: fc_gathervr4 +#endif +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + real(r4), intent(in):: localchunks(fdim,pcols,mdim, & + begchunk:endchunk,ldim) + ! local chunks + + real(r4), intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) + ! global field + +!---------------------------Local workspace----------------------------- + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + real(r4) gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be gathered + real(r4) lfield_p(fdim,mdim,ldim,nlcols) + ! local component of gather + ! vector + integer :: displs(0:npes-1) ! gather displacements + integer :: rcvcnts(0:npes-1) ! gather receive count + integer :: sendcnt ! gather send counts + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + call endrun ('GATHER_CHUNK_TO_FIELD4 error: hdim1d < hdim1_d') + endif +#if ( defined SPMD ) + displs(0) = 0 + rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + rcvcnts(p-1) + rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + sendcnt = fdim*mdim*ldim*nlcols + +! copy into local gather data structure + + do l=1,ldim + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do m=1,mdim + do f=1,fdim + lfield_p(f, m, l, i) = & + localchunks(f,lid,m,lcid,l) + end do + end do + end do + end do + +! gather from other processes + + call t_barrierf('sync_gath_ctof', mpicom) + call fc_gathervr4(lfield_p, sendcnt, mpir4, & + gfield_p, rcvcnts, displs, mpir4, 0, mpicom) + + if (masterproc) then + +! copy gathered columns into lon/lat field + + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do l=1,ldim + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = gfield_p(f,m,l,i) + end do + end do + end do + end do + endif + +#else + +! copy chunked data structure into dynamics field +! (pgcol ordering chosen to reflect begchunk:endchunk +! local ordering) + + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = localchunks(f,lid,m,lcid,l) + end do + end do + end do + end do - end function get_ncols_p +#endif - !======================================================================== + return + end subroutine gather_chunk_to_field4 - real(r8) function get_area_p(lcid, col) - ! area of a physics column in radians squared +! +!======================================================================== +! + subroutine gather_chunk_to_field_int (fdim,mdim,ldim, & + hdim1d,localchunks,globalfield) - ! Dummy arguments - integer, intent(in) :: lcid ! Chunk number - integer, intent(in) :: col ! column - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_area_p' +!----------------------------------------------------------------------- +! +! Purpose: Reconstruct field +! from decomposed chunk data structure +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +#if ( defined SPMD ) + use spmd_utils, only: fc_gathervint +#endif +!------------------------------Arguments-------------------------------- + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + integer, intent(in) :: hdim1d ! declared first horizontal index + ! dimension + integer, intent(in):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks + + integer, intent(out) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) ! global field + +!---------------------------Local workspace----------------------------- + + integer :: f,i,m,l,p ! loop indices + integer :: cid ! global chunk id + integer :: lcid ! local chunk id + integer :: lid ! local column index + integer :: gcol ! global column index + integer :: h1 ! first horizontal dimension index + integer :: h2 ! second horizontal dimension index + +#if ( defined SPMD ) + integer gfield_p(fdim,mdim,ldim,ngcols) + ! vector to be gathered + integer lfield_p(fdim,mdim,ldim,nlcols) + ! local component of gather + ! vector + integer :: displs(0:npes-1) ! gather displacements + integer :: rcvcnts(0:npes-1) ! gather receive count + integer :: sendcnt ! gather send counts + integer :: beglcol ! beginning index for local columns + ! in global column ordering +#endif + +!----------------------------------------------------------------------- + if (hdim1d < hdim1_d) then + call endrun ('GATHER_CHUNK_TO_FIELD_INT error: hdim1d < hdim1_d') + endif +#if ( defined SPMD ) + displs(0) = 0 + rcvcnts(0) = fdim*mdim*ldim*gs_col_num(0) + beglcol = 0 + do p=1,npes-1 + displs(p) = displs(p-1) + rcvcnts(p-1) + rcvcnts(p) = fdim*mdim*ldim*gs_col_num(p) + if (p <= iam) then + beglcol = beglcol + gs_col_num(p-1) + endif + enddo + sendcnt = fdim*mdim*ldim*nlcols + +! copy into local gather data structure + + do l=1,ldim + do i=1,nlcols + cid = pgcols(beglcol+i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(beglcol+i)%ccol + do m=1,mdim + do f=1,fdim + lfield_p(f, m, l, i) = & + localchunks(f,lid,m,lcid,l) + end do + end do + end do + end do + +! gather from other processes + + call t_barrierf('sync_gath_ctof', mpicom) + call fc_gathervint(lfield_p, sendcnt, mpiint, & + gfield_p, rcvcnts, displs, mpiint, 0, mpicom) + + if (masterproc) then + +! copy gathered columns into lon/lat field + + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do l=1,ldim + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = gfield_p(f,m,l,i) + end do + end do + end do + end do + endif + +#else + + ! copy chunked data structure into lon/lat field + ! (pgcol ordering chosen to reflect begchunk:endchunk + ! local ordering) + do l=1,ldim + do i=1,num_global_phys_cols + cid = pgcols(i)%chunk + lcid = chunks(cid)%lcid + lid = pgcols(i)%ccol + gcol = chunks(cid)%gcol(lid) + h2 = (gcol-1)/hdim1_d + 1 + h1 = mod((gcol-1),hdim1_d) + 1 + do m=1,mdim + do f=1,fdim + globalfield(f, h1, m, h2, l) & + = localchunks(f,lid,m,lcid,l) + end do + end do + end do + end do - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_area_p = phys_columns(index)%area +#endif - end function get_area_p + return + end subroutine gather_chunk_to_field_int - !======================================================================== +! +!======================================================================== +! + subroutine write_field_from_chunk(iu,fdim,mdim,ldim,localchunks) - real(r8) function get_wght_p(lcid, col) - ! weight of a physics column in radians squared +!----------------------------------------------------------------------- +! +! +! Purpose: Write field from decomposed chunk data +! structure +! +! Method: +! +! Author: Patrick Worley +! +!------------------------------Arguments-------------------------------- + integer, intent(in) :: iu ! logical unit + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension + real(r8), intent(in):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks - ! Dummy arguments - integer, intent(in) :: lcid ! Chunk number - integer, intent(in) :: col ! column - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_wght_p' +!---------------------------Local workspace----------------------------- - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_wght_p = phys_columns(index)%weight + integer :: ioerr ! error return - end function get_wght_p + real(r8), allocatable :: globalfield(:,:,:,:,:) + ! global field +!----------------------------------------------------------------------- - !======================================================================== + allocate(globalfield(fdim,hdim1_d,mdim,hdim2_d,ldim)) - integer function get_gcol_p(lcid, col) - ! global column index of a physics column + call gather_chunk_to_field (fdim,mdim,ldim,hdim1_d,localchunks,globalfield) - ! Dummy arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! column index - ! Local variables - integer :: index - character(len=*), parameter :: subname = 'get_gcol_p: ' + if (masterproc) then + write (iu,iostat=ioerr) globalfield + if (ioerr /= 0 ) then + write(iulog,*) 'WRITE_FIELD_FROM_CHUNK ioerror ', ioerr,' on i/o unit = ',iu + call endrun + end if + endif - index = chunk_info_to_index_p(lcid, col, subname_in=subname) - get_gcol_p = phys_columns(index)%global_col_num + deallocate(globalfield) - end function get_gcol_p + return + end subroutine write_field_from_chunk - !======================================================================== +! +!======================================================================== +! + subroutine read_chunk_from_field(iu,fdim,mdim,ldim,localchunks) - subroutine get_dyn_col_p_chunk(lcid, col, blk_num, blk_ind, caller) - use cam_abortutils, only: endrun - ! Return the dynamics local block number and block offset(s) for - ! the physics column indicated by (chunk) and (column). - - ! Dummy arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: col ! Column index - integer, intent(out) :: blk_num ! Local dynamics block index - integer, intent(out) :: blk_ind(:) ! Local dynamics block offset(s) - character(len=*), optional, intent(in) :: caller ! Calling routine - ! Local variables - integer :: index - integer :: off_size - character(len=*), parameter :: subname = 'get_dyn_col_p_chunk: ' - - index = chunk_info_to_index_p(lcid, col) - off_size = SIZE(phys_columns(index)%dyn_block_index, 1) - if (SIZE(blk_ind, 1) < off_size) then - if (present(caller)) then - call endrun(trim(caller)//': blk_ind too small') - else - call endrun(subname//'blk_ind too small') - end if - end if - blk_num = phys_columns(index)%local_dyn_block - blk_ind(1:off_size) = phys_columns(index)%dyn_block_index(1:off_size) - if (SIZE(blk_ind, 1) > off_size) then - blk_ind(off_size+1:) = -1 - end if +!----------------------------------------------------------------------- +! +! +! Purpose: Write field from decomposed chunk data +! structure +! +! Method: +! +! Author: Patrick Worley +! +!------------------------------Arguments-------------------------------- + integer, intent(in) :: iu ! logical unit + integer, intent(in) :: fdim ! declared length of first dimension + integer, intent(in) :: mdim ! declared length of middle dimension + integer, intent(in) :: ldim ! declared length of last dimension - end subroutine get_dyn_col_p_chunk + real(r8), intent(out):: localchunks(fdim,pcols,mdim,begchunk:endchunk,ldim) ! local chunks - !======================================================================== +!---------------------------Local workspace----------------------------- - subroutine get_dyn_col_p_index(index, blk_num, blk_ind) - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - ! Return the dynamics local block number and block offset(s) for - ! the physics column indicated by . - - ! Dummy arguments - integer, intent(in) :: index ! index of local physics column - integer, intent(out) :: blk_num ! Local dynamics block index - integer, intent(out) :: blk_ind(:) ! Local dynamics block offset(s) - ! Local variables - integer :: off_size - character(len=128) :: errmsg - character(len=*), parameter :: subname = 'get_dyn_col_p_index: ' + integer :: ioerr ! error return - if (.not. phys_grid_initialized()) then - call endrun(subname//'physics grid not initialized') - else if ((index < 1) .or. (index > columns_on_task)) then - write(errmsg, '(a,2(a,i0))') subname, 'index (', index, & - ') out of range (1 to ', columns_on_task - write(iulog, *) trim(errmsg) - call endrun(trim(errmsg)) - else - off_size = SIZE(phys_columns(index)%dyn_block_index, 1) - if (SIZE(blk_ind, 1) < off_size) then - call endrun(subname//'blk_ind too small') - end if - blk_num = phys_columns(index)%local_dyn_block - blk_ind(1:off_size) = phys_columns(index)%dyn_block_index(1:off_size) - if (SIZE(blk_ind, 1) > off_size) then - blk_ind(off_size+1:) = -1 - end if + real(r8), allocatable :: globalfield(:,:,:,:,:) + ! global field +!----------------------------------------------------------------------- + + allocate(globalfield(fdim,hdim1_d,mdim,hdim2_d,ldim)) + + if (masterproc) then + read (iu,iostat=ioerr) globalfield + if (ioerr /= 0 ) then + write(iulog,*) 'READ_CHUNK_FROM_FIELD ioerror ', ioerr,' on i/o unit = ',iu + call endrun end if + endif - end subroutine get_dyn_col_p_index + call scatter_field_to_chunk (fdim,mdim,ldim,hdim1_d,globalfield,localchunks) - !======================================================================== + deallocate(globalfield) - subroutine get_gcol_all_p(lcid, gdim, gcols) - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use spmd_utils, only: masterproc - ! collect global column indices of all physics columns in a chunk - - ! Dummy arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: gdim ! gcols dimension - integer, intent(out) :: gcols(:) ! global column indices - ! Local variables - integer :: ncol, col_ind - character(len=128) :: errmsg - character(len=*), parameter :: subname = 'get_gcol_all_p: ' + return + end subroutine read_chunk_from_field +! +!======================================================================== - if (.not. phys_grid_initialized()) then - call endrun(subname//'physics grid not initialized') - else if ((lcid < begchunk) .or. (lcid > endchunk)) then - write(errmsg, '(a,3(a,i0))') subname, 'lcid (', lcid, & - ') out of range (', begchunk, ' to ', endchunk - write(iulog, *) trim(errmsg) - call endrun(trim(errmsg)) + subroutine transpose_block_to_chunk(record_size, block_buffer, & + chunk_buffer, window) + +!----------------------------------------------------------------------- +! +! Purpose: Transpose buffer containing decomposed +! fields to buffer +! containing decomposed chunk data structures +! +! Method: +! +! Author: Patrick Worley +! Modified: Art Mirin, Jan 04, to add support for mod_comm +! +!----------------------------------------------------------------------- +#if ( defined SPMD ) +# if defined(MODCM_DP_TRANSPOSE) + use mod_comm, only: blockdescriptor, mp_sendirr, mp_recvirr, & + get_partneroffset, max_nparcels + use mpishorthand, only : mpicom +# endif + use spmd_utils, only: altalltoallv +#endif +!------------------------------Parameters------------------------------- +! + integer, parameter :: msgtag = 6000 +!------------------------------Arguments-------------------------------- + integer, intent(in) :: record_size ! per column amount of data + real(r8), intent(in) :: block_buffer(record_size*block_buf_nrecs) + ! buffer of block data to be + ! transposed + real(r8), intent(out):: chunk_buffer(record_size*chunk_buf_nrecs) + ! buffer of chunk data + ! transposed into + integer, intent(in), optional :: window + ! MPI-2 window id for + ! chunk_buffer + +!---------------------------Local workspace----------------------------- +#if ( defined SPMD ) + integer :: p ! loop indices + integer :: bbuf_siz ! size of block_buffer + integer :: cbuf_siz ! size of chunk_buffer + integer :: lwindow ! placeholder for missing window + integer :: lopt ! local copy of phys_alltoall +! + logical, save :: first = .true. + integer, allocatable, save :: sndcnts(:), sdispls(:) + integer, allocatable, save :: rcvcnts(:), rdispls(:) + integer, allocatable, save :: pdispls(:) + integer, save :: prev_record_size = 0 +# if defined(MODCM_DP_TRANSPOSE) + type (blockdescriptor), allocatable, save :: sendbl(:), recvbl(:) + integer ione, ierror, mod_method +# endif +!----------------------------------------------------------------------- + if (first) then +! Compute send/recv/put counts and displacements + allocate(sndcnts(0:npes-1)) + allocate(sdispls(0:npes-1)) + allocate(rcvcnts(0:npes-1)) + allocate(rdispls(0:npes-1)) + allocate(pdispls(0:npes-1)) +! +# if defined(MODCM_DP_TRANSPOSE) +! This branch uses mod_comm. Admissable values of phys_alltoall are +! 11,12 and 13. Each value corresponds to a different option +! within mod_comm of implementing the communication. That option is expressed +! internally to mod_comm using the variable mod_method defined below; +! mod_method will have values 0,1 or 2 and is defined as +! phys_alltoall - modmin_alltoall, where modmin_alltoall equals 11. +! Also, sendbl and recvbl must have exactly npes elements, to match +! this size of the communicator, or the transpose will fail. +! + if (phys_alltoall >= modmin_alltoall) then + mod_method = phys_alltoall - modmin_alltoall + ione = 1 + allocate( sendbl(0:npes-1) ) + allocate( recvbl(0:npes-1) ) + + do p = 0,npes-1 + + sendbl(p)%method = mod_method + recvbl(p)%method = mod_method + + allocate( sendbl(p)%blocksizes(1) ) + allocate( sendbl(p)%displacements(1) ) + allocate( recvbl(p)%blocksizes(1) ) + allocate( recvbl(p)%displacements(1) ) + + enddo + + endif +# endif + + first = .false. + endif +! + if (record_size /= prev_record_size) then +! +! Compute send/recv/put counts and displacements + sdispls(0) = 0 + sndcnts(0) = record_size*btofc_blk_num(0) + do p=1,npes-1 + sdispls(p) = sdispls(p-1) + sndcnts(p-1) + sndcnts(p) = record_size*btofc_blk_num(p) + enddo +! + rdispls(0) = 0 + rcvcnts(0) = record_size*btofc_chk_num(0) + do p=1,npes-1 + rdispls(p) = rdispls(p-1) + rcvcnts(p-1) + rcvcnts(p) = record_size*btofc_chk_num(p) + enddo +! + call mpialltoallint(rdispls, 1, pdispls, 1, mpicom) +! +# if defined(MODCM_DP_TRANSPOSE) + if (phys_alltoall >= modmin_alltoall) then + do p = 0,npes-1 + + sendbl(p)%type = MPI_DATATYPE_NULL + if ( sndcnts(p) /= 0 ) then + + if (phys_alltoall > modmin_alltoall) then + call MPI_TYPE_INDEXED(ione, sndcnts(p), & + sdispls(p), mpir8, & + sendbl(p)%type, ierror) + call MPI_TYPE_COMMIT(sendbl(p)%type, ierror) + endif + + sendbl(p)%blocksizes(1) = sndcnts(p) + sendbl(p)%displacements(1) = sdispls(p) + sendbl(p)%partneroffset = 0 + + else + + sendbl(p)%blocksizes(1) = 0 + sendbl(p)%displacements(1) = 0 + sendbl(p)%partneroffset = 0 + + endif + sendbl(p)%nparcels = size(sendbl(p)%displacements) + sendbl(p)%tot_size = sum(sendbl(p)%blocksizes) + max_nparcels = max(max_nparcels, sendbl(p)%nparcels) + + recvbl(p)%type = MPI_DATATYPE_NULL + if ( rcvcnts(p) /= 0) then + + if (phys_alltoall > modmin_alltoall) then + call MPI_TYPE_INDEXED(ione, rcvcnts(p), & + rdispls(p), mpir8, & + recvbl(p)%type, ierror) + call MPI_TYPE_COMMIT(recvbl(p)%type, ierror) + endif + + recvbl(p)%blocksizes(1) = rcvcnts(p) + recvbl(p)%displacements(1) = rdispls(p) + recvbl(p)%partneroffset = 0 ! not properly initialized - do not use Mpi2 + else + + recvbl(p)%blocksizes(1) = 0 + recvbl(p)%displacements(1) = 0 + recvbl(p)%partneroffset = 0 + + endif + recvbl(p)%nparcels = size(recvbl(p)%displacements) + recvbl(p)%tot_size = sum(recvbl(p)%blocksizes) + max_nparcels = max(max_nparcels, recvbl(p)%nparcels) + + enddo + + call get_partneroffset(mpicom, sendbl, recvbl) + + endif +# endif +! + prev_record_size = record_size + endif +! + call t_barrierf('sync_tran_btoc', mpicom) + if (phys_alltoall < 0) then + if ((max_nproc_smpx > npes/2) .and. (nproc_busy_d > npes/2)) then + lopt = 0 else - ncol = chunks(lcid)%ncols - if (gdim < ncol) then - if (masterproc) then - write(iulog, '(2a,2(i0,a))') subname, 'WARNING: gdim (', gdim, & - ') < ncol (', ncol,'), not all indices will be filled.' - end if - gcols(gdim+1:ncol) = -1 - end if - do col_ind = 1, MIN(ncol, gdim) - gcols(col_ind) = get_gcol_p(lcid, col_ind) - end do - end if + lopt = 1 + endif + else + lopt = phys_alltoall + if ((lopt == 2) .and. ( .not. present(window) )) lopt = 1 + endif + if (lopt < 4) then +! + bbuf_siz = record_size*block_buf_nrecs + cbuf_siz = record_size*chunk_buf_nrecs + if ( present(window) ) then + call altalltoallv(lopt, iam, npes, & + dp_coup_steps, dp_coup_proc, & + block_buffer, bbuf_siz, sndcnts, sdispls, mpir8, & + chunk_buffer, cbuf_siz, rcvcnts, rdispls, mpir8, & + msgtag, pdispls, mpir8, window, mpicom) + else + call altalltoallv(lopt, iam, npes, & + dp_coup_steps, dp_coup_proc, & + block_buffer, bbuf_siz, sndcnts, sdispls, mpir8, & + chunk_buffer, cbuf_siz, rcvcnts, rdispls, mpir8, & + msgtag, pdispls, mpir8, lwindow, mpicom) + endif +! + else +! +# if defined(MODCM_DP_TRANSPOSE) + call mp_sendirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) + call mp_recvirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) +# else + call mpialltoallv(block_buffer, sndcnts, sdispls, mpir8, & + chunk_buffer, rcvcnts, rdispls, mpir8, & + mpicom) +# endif +! + endif +! +#endif + return + end subroutine transpose_block_to_chunk +! +!======================================================================== - end subroutine get_gcol_all_p + subroutine block_to_chunk_send_pters(blockid, fdim, ldim, & + record_size, pter) +!----------------------------------------------------------------------- +! +! Purpose: Return pointers into send buffer where column from decomposed +! fields should be copied to +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: blockid ! block index + integer, intent(in) :: fdim ! first dimension of pter array + integer, intent(in) :: ldim ! last dimension of pter array + integer, intent(in) :: record_size ! per coordinate amount of data + + integer, intent(out) :: pter(fdim,ldim) ! buffer offsets +!---------------------------Local workspace----------------------------- + integer :: i, k ! loop indices +!----------------------------------------------------------------------- + if ((btofc_blk_offset(blockid)%ncols > fdim) .or. & + (btofc_blk_offset(blockid)%nlvls > ldim)) then + write(iulog,*) "BLOCK_TO_CHUNK_SEND_PTERS: pter array dimensions ", & + "not large enough: (",fdim,",",ldim,") not >= (", & + btofc_blk_offset(blockid)%ncols,",", & + btofc_blk_offset(blockid)%nlvls,")" + call endrun() + endif +! + do k=1,btofc_blk_offset(blockid)%nlvls + do i=1,btofc_blk_offset(blockid)%ncols + pter(i,k) = 1 + record_size* & + (btofc_blk_offset(blockid)%pter(i,k)) + enddo + do i=btofc_blk_offset(blockid)%ncols+1,fdim + pter(i,k) = -1 + enddo + enddo +! + do k=btofc_blk_offset(blockid)%nlvls+1,ldim + do i=1,fdim + pter(i,k) = -1 + enddo + enddo +! + return + end subroutine block_to_chunk_send_pters +! +!======================================================================== - !======================================================================== + subroutine block_to_chunk_recv_pters(lcid, fdim, ldim, & + record_size, pter) +!----------------------------------------------------------------------- +! +! Purpose: Return pointers into receive buffer where data for +! decomposed chunk data structures should be copied from +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: fdim ! first dimension of pter array + integer, intent(in) :: ldim ! last dimension of pter array + integer, intent(in) :: record_size ! per coordinate amount of data + + integer, intent(out) :: pter(fdim,ldim) ! buffer offset +!---------------------------Local workspace----------------------------- + integer :: i, k ! loop indices +!----------------------------------------------------------------------- + if ((btofc_chk_offset(lcid)%ncols > fdim) .or. & + (btofc_chk_offset(lcid)%nlvls > ldim)) then + write(iulog,*) "BLOCK_TO_CHUNK_RECV_PTERS: pter array dimensions ", & + "not large enough: (",fdim,",",ldim,") not >= (", & + btofc_chk_offset(lcid)%ncols,",", & + btofc_chk_offset(lcid)%nlvls,")" + call endrun() + endif +! + do k=1,btofc_chk_offset(lcid)%nlvls + do i=1,btofc_chk_offset(lcid)%ncols + pter(i,k) = 1 + record_size* & + (btofc_chk_offset(lcid)%pter(i,k)) + enddo + do i=btofc_chk_offset(lcid)%ncols+1,fdim + pter(i,k) = -1 + enddo + enddo +! + do k=btofc_chk_offset(lcid)%nlvls+1,ldim + do i=1,fdim + pter(i,k) = -1 + enddo + enddo +! + return + end subroutine block_to_chunk_recv_pters +! +!======================================================================== - subroutine get_chunk_info_p(index, lchnk, icol) - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - ! local chunk index and column number of a physics column + subroutine transpose_chunk_to_block(record_size, chunk_buffer, & + block_buffer, window) +!----------------------------------------------------------------------- +! +! Purpose: Transpose buffer containing decomposed +! chunk data structures to buffer +! containing decomposed fields +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +#if ( defined SPMD ) +# if defined(MODCM_DP_TRANSPOSE) + use mod_comm, only: blockdescriptor, mp_sendirr, mp_recvirr, & + get_partneroffset, max_nparcels + use mpishorthand, only : mpicom +# endif + use spmd_utils, only: altalltoallv +#endif +!------------------------------Parameters------------------------------- +! + integer, parameter :: msgtag = 7000 +!------------------------------Arguments-------------------------------- + integer, intent(in) :: record_size ! per column amount of data + real(r8), intent(in):: chunk_buffer(record_size*chunk_buf_nrecs) + ! buffer of chunk data to be + ! transposed + real(r8), intent(out) :: block_buffer(record_size*block_buf_nrecs) + ! buffer of block data to + ! transpose into + integer, intent(in), optional :: window + ! MPI-2 window id for + ! chunk_buffer + +!---------------------------Local workspace----------------------------- +#if ( defined SPMD ) + integer :: p ! loop indices + integer :: bbuf_siz ! size of block_buffer + integer :: cbuf_siz ! size of chunk_buffer + integer :: lwindow ! placeholder for missing window + integer :: lopt ! local copy of phys_alltoall +! + logical, save :: first = .true. + integer, allocatable, save :: sndcnts(:), sdispls(:) + integer, allocatable, save :: rcvcnts(:), rdispls(:) + integer, allocatable, save :: pdispls(:) + integer, save :: prev_record_size = 0 +# if defined(MODCM_DP_TRANSPOSE) + type (blockdescriptor), allocatable, save :: sendbl(:), recvbl(:) + integer ione, ierror, mod_method +# endif +!----------------------------------------------------------------------- + if (first) then +! Compute send/recv/put counts and displacements + allocate(sndcnts(0:npes-1)) + allocate(sdispls(0:npes-1)) + allocate(rcvcnts(0:npes-1)) + allocate(rdispls(0:npes-1)) + allocate(pdispls(0:npes-1)) +! +# if defined(MODCM_DP_TRANSPOSE) +! This branch uses mod_comm. Admissable values of phys_alltoall are +! 11,12 and 13. Each value corresponds to a differerent option +! within mod_comm of implementing the communication. That option is expressed +! internally to mod_comm using the variable mod_method defined below; +! mod_method will have values 0,1 or 2 and is defined as +! phys_alltoall - modmin_alltoall, where modmin_alltoall equals 11. +! Also, sendbl and recvbl must have exactly npes elements, to match +! this size of the communicator, or the transpose will fail. +! + if (phys_alltoall >= modmin_alltoall) then + mod_method = phys_alltoall - modmin_alltoall + ione = 1 + allocate( sendbl(0:npes-1) ) + allocate( recvbl(0:npes-1) ) - ! Dummy arguments - integer, intent(in) :: index - integer, intent(out) :: lchnk - integer, intent(out) :: icol - ! Local variables - character(len=128) :: errmsg - character(len=*), parameter :: subname = 'get_chunk_info_p: ' + do p = 0,npes-1 - if (.not. phys_grid_initialized()) then - call endrun(subname//': physics grid not initialized') - else if ((index < 1) .or. (index > columns_on_task)) then - write(errmsg, '(a,2(a,i0))') subname, 'index (', index, & - ') out of range (1 to ', columns_on_task - write(iulog, *) errmsg - call endrun(errmsg) + sendbl(p)%method = mod_method + recvbl(p)%method = mod_method + + allocate( sendbl(p)%blocksizes(1) ) + allocate( sendbl(p)%displacements(1) ) + allocate( recvbl(p)%blocksizes(1) ) + allocate( recvbl(p)%displacements(1) ) + + enddo + + endif +# endif +! + first = .false. + endif +! + if (record_size /= prev_record_size) then +! +! Compute send/recv/put counts and displacements + sdispls(0) = 0 + sndcnts(0) = record_size*btofc_chk_num(0) + do p=1,npes-1 + sdispls(p) = sdispls(p-1) + sndcnts(p-1) + sndcnts(p) = record_size*btofc_chk_num(p) + enddo +! + rdispls(0) = 0 + rcvcnts(0) = record_size*btofc_blk_num(0) + do p=1,npes-1 + rdispls(p) = rdispls(p-1) + rcvcnts(p-1) + rcvcnts(p) = record_size*btofc_blk_num(p) + enddo +! + call mpialltoallint(rdispls, 1, pdispls, 1, mpicom) +! +# if defined(MODCM_DP_TRANSPOSE) + if (phys_alltoall >= modmin_alltoall) then + do p = 0,npes-1 + + sendbl(p)%type = MPI_DATATYPE_NULL + if ( sndcnts(p) /= 0 ) then + + if (phys_alltoall > modmin_alltoall) then + call MPI_TYPE_INDEXED(ione, sndcnts(p), & + sdispls(p), mpir8, & + sendbl(p)%type, ierror) + call MPI_TYPE_COMMIT(sendbl(p)%type, ierror) + endif + + sendbl(p)%blocksizes(1) = sndcnts(p) + sendbl(p)%displacements(1) = sdispls(p) + sendbl(p)%partneroffset = 0 + + else + + sendbl(p)%blocksizes(1) = 0 + sendbl(p)%displacements(1) = 0 + sendbl(p)%partneroffset = 0 + + endif + sendbl(p)%nparcels = size(sendbl(p)%displacements) + sendbl(p)%tot_size = sum(sendbl(p)%blocksizes) + max_nparcels = max(max_nparcels, sendbl(p)%nparcels) + + recvbl(p)%type = MPI_DATATYPE_NULL + if ( rcvcnts(p) /= 0) then + + if (phys_alltoall > modmin_alltoall) then + call MPI_TYPE_INDEXED(ione, rcvcnts(p), & + rdispls(p), mpir8, & + recvbl(p)%type, ierror) + call MPI_TYPE_COMMIT(recvbl(p)%type, ierror) + endif + + recvbl(p)%blocksizes(1) = rcvcnts(p) + recvbl(p)%displacements(1) = rdispls(p) + recvbl(p)%partneroffset = 0 ! not properly initialized - do not use Mpi2 + else + + recvbl(p)%blocksizes(1) = 0 + recvbl(p)%displacements(1) = 0 + recvbl(p)%partneroffset = 0 + + endif + recvbl(p)%nparcels = size(recvbl(p)%displacements) + recvbl(p)%tot_size = sum(recvbl(p)%blocksizes) + max_nparcels = max(max_nparcels, recvbl(p)%nparcels) + + enddo + + call get_partneroffset(mpicom, sendbl, recvbl) + + endif +# endif +! + prev_record_size = record_size + endif +! + call t_barrierf('sync_tran_ctob', mpicom) + if (phys_alltoall < 0) then + if ((max_nproc_smpx > npes/2) .and. (nproc_busy_d > npes/2)) then + lopt = 0 else - lchnk = phys_columns(index)%local_phys_chunk - icol = phys_columns(index)%phys_chunk_index - end if + lopt = 1 + endif + else + lopt = phys_alltoall + if ((lopt == 2) .and. ( .not. present(window) )) lopt = 1 + endif + if (lopt < 4) then +! + bbuf_siz = record_size*block_buf_nrecs + cbuf_siz = record_size*chunk_buf_nrecs + if ( present(window) ) then + call altalltoallv(lopt, iam, npes, & + dp_coup_steps, dp_coup_proc, & + chunk_buffer, cbuf_siz, sndcnts, sdispls, mpir8, & + block_buffer, bbuf_siz, rcvcnts, rdispls, mpir8, & + msgtag, pdispls, mpir8, window, mpicom) + else + call altalltoallv(lopt, iam, npes, & + dp_coup_steps, dp_coup_proc, & + chunk_buffer, cbuf_siz, sndcnts, sdispls, mpir8, & + block_buffer, bbuf_siz, rcvcnts, rdispls, mpir8, & + msgtag, pdispls, mpir8, lwindow, mpicom) + endif +! + else +# if defined(MODCM_DP_TRANSPOSE) + call mp_sendirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) + call mp_recvirr(mpicom, sendbl, recvbl, block_buffer, chunk_buffer) +# else + call mpialltoallv(chunk_buffer, sndcnts, sdispls, mpir8, & + block_buffer, rcvcnts, rdispls, mpir8, & + mpicom) +# endif +! + endif +! +#endif - end subroutine get_chunk_info_p + return + end subroutine transpose_chunk_to_block +! +!======================================================================== - !======================================================================== + subroutine chunk_to_block_send_pters(lcid, fdim, ldim, & + record_size, pter) +!----------------------------------------------------------------------- +! +! Purpose: Return pointers into send buffer where data for +! decomposed chunk data structures should be copied to +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: lcid ! local chunk id + integer, intent(in) :: fdim ! first dimension of pter array + integer, intent(in) :: ldim ! last dimension of pter array + integer, intent(in) :: record_size ! per coordinate amount of data + + integer, intent(out) :: pter(fdim,ldim) ! buffer offset +!---------------------------Local workspace----------------------------- + integer :: i, k ! loop indices +!----------------------------------------------------------------------- + if ((btofc_chk_offset(lcid)%ncols > fdim) .or. & + (btofc_chk_offset(lcid)%nlvls > ldim)) then + write(iulog,*) "CHUNK_TO_BLOCK_SEND_PTERS: pter array dimensions ", & + "not large enough: (",fdim,",",ldim,") not >= (", & + btofc_chk_offset(lcid)%ncols,",", & + btofc_chk_offset(lcid)%nlvls,")" + call endrun() + endif +! + do k=1,btofc_chk_offset(lcid)%nlvls + do i=1,btofc_chk_offset(lcid)%ncols + pter(i,k) = 1 + record_size* & + (btofc_chk_offset(lcid)%pter(i,k)) + enddo + do i=btofc_chk_offset(lcid)%ncols+1,fdim + pter(i,k) = -1 + enddo + enddo +! + do k=btofc_chk_offset(lcid)%nlvls+1,ldim + do i=1,fdim + pter(i,k) = -1 + enddo + enddo +! + return + end subroutine chunk_to_block_send_pters +! +!======================================================================== - subroutine get_grid_dims(hdim1_d_out, hdim2_d_out) - use cam_abortutils, only: endrun - ! retrieve dynamics field grid information - ! hdim1_d and hdim2_d are dimensions of rectangular horizontal grid - ! data structure, If 1D data structure, then hdim2_d == 1. - integer, intent(out) :: hdim1_d_out - integer, intent(out) :: hdim2_d_out + subroutine chunk_to_block_recv_pters(blockid, fdim, ldim, & + record_size, pter) +!----------------------------------------------------------------------- +! +! Purpose: Return pointers into receive buffer where column from decomposed +! fields should be copied from +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: blockid ! block index + integer, intent(in) :: fdim ! first dimension of pter array + integer, intent(in) :: ldim ! last dimension of pter array + integer, intent(in) :: record_size ! per coordinate amount of data + + integer, intent(out) :: pter(fdim,ldim) ! buffer offsets +!---------------------------Local workspace----------------------------- + integer :: i, k ! loop indices +!----------------------------------------------------------------------- + if ((btofc_blk_offset(blockid)%ncols > fdim) .or. & + (btofc_blk_offset(blockid)%nlvls > ldim)) then + write(iulog,*) "CHUNK_TO_BLOCK_RECV_PTERS: pter array dimensions ", & + "not large enough: (",fdim,",",ldim,") not >= (", & + btofc_blk_offset(blockid)%ncols,",", & + btofc_blk_offset(blockid)%nlvls,")" + call endrun() + endif +! + do k=1,btofc_blk_offset(blockid)%nlvls + do i=1,btofc_blk_offset(blockid)%ncols + pter(i,k) = 1 + record_size* & + (btofc_blk_offset(blockid)%pter(i,k)) + enddo + do i=btofc_blk_offset(blockid)%ncols+1,fdim + pter(i,k) = -1 + enddo + enddo +! + do k=btofc_blk_offset(blockid)%nlvls+1,ldim + do i=1,fdim + pter(i,k) = -1 + enddo + enddo +! + return + end subroutine chunk_to_block_recv_pters +! +!======================================================================== - if (.not. phys_grid_initialized()) then - call endrun('get_grid_dims: physics grid not initialized') - end if - hdim1_d_out = hdim1_d - hdim2_d_out = hdim2_d + subroutine create_chunks(opt, chunks_per_thread) +!----------------------------------------------------------------------- +! +! Purpose: Decompose physics computational grid into chunks, for +! improved serial efficiency and parallel load balance. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use pmgrid, only: plev + use dyn_grid, only: get_block_bounds_d, get_block_gcol_cnt_d, & + get_gcol_block_cnt_d, get_gcol_block_d, & + get_block_owner_d, get_block_gcol_d +!------------------------------Arguments-------------------------------- + integer, intent(in) :: opt ! chunking option + ! 0: chunks may cross block boundaries, but retain same + ! process mapping as blocks. If possible, columns assigned + ! as day/night pairs. Columns (or pairs) are wrap-mapped. + ! May not work with vertically decomposed blocks. (default) + ! 1: chunks may cross block boundaries, but retain same + ! SMP-node mapping as blocks. If possible, columns assigned + ! as day/night pairs. Columns (or pairs) are wrap-mapped. + ! May not work with vertically decomposed blocks. + ! 2: 2-column day/night and season column pairs wrap-mapped + ! to chunks to also balance assignment of polar, mid-latitude, + ! and equatorial columns across chunks. + ! 3: same as 1 except that SMP defined to be pairs of consecutive + ! processes + ! 4: chunks may cross block boundaries, but retain same + ! process mapping as blocks. Columns assigned to chunks + ! in block ordering. + ! May not work with vertically decomposed blocks. + ! 5: Chunks do not cross latitude boundaries, and are block-mapped. + integer, intent(in) :: chunks_per_thread + ! target number of chunks per + ! thread +!---------------------------Local workspace----------------------------- + integer :: i, j, p ! loop indices + integer :: nlthreads ! number of local OpenMP threads + integer :: npthreads(0:npes-1) ! number of OpenMP threads per process + integer :: proc_smp_mapx(0:npes-1) ! process/virtual SMP node map + integer :: firstblock, lastblock ! global block index bounds + integer :: maxblksiz ! maximum number of columns in a dynamics block + integer :: block_cnt ! number of blocks containing data + ! for a given vertical column + integer :: blockids(plev+1) ! block indices + integer :: bcids(plev+1) ! block column indices + integer :: nsmpx, nsmpy ! virtual SMP node counts and indices + integer :: curgcol, twingcol ! global physics and dynamics column indices + integer :: smp ! SMP node index + integer :: cid ! chunk id + integer :: jb, ib ! global block and columns indices + integer :: blksiz ! current block size + integer :: ntmp1, ntmp2, nlchunks ! work variables + integer :: max_ncols ! upper bound on number of columns in a block + integer :: ncols ! number of columns in current chunk + logical :: error ! error flag + + ! indices for dynamics columns in given block + integer, dimension(:), allocatable :: cols + + ! number of MPI processes per virtual SMP node (0:nsmpx-1) + integer, dimension(:), allocatable :: nsmpprocs + + ! flag indicating whether a process is busy or idle during the dynamics (0:npes-1) + logical, dimension(:), allocatable :: proc_busy_d + + ! flag indicating whether any of the processes assigned to an SMP node are busy + ! during the dynamics, or whether all of them are idle (0:nsmps-1) + logical, dimension(:), allocatable :: smp_busy_d + + ! actual SMP node/virtual SMP node map (0:nsmps-1) + integer, dimension(:), allocatable :: smp_smp_mapx + + ! column/virtual SMP node map (ngcols) + integer, dimension(:), allocatable :: col_smp_mapx + + ! number of columns assigned to a given virtual SMP node (0:nsmpx-1) + integer, dimension(:), allocatable :: nsmpcolumns + + ! number of OpenMP threads per virtual SMP node (0:nsmpx-1) + integer, dimension(:), allocatable :: nsmpthreads + + ! number of chunks assigned to a given virtual SMP node (0:nsmpx-1) + integer, dimension(:), allocatable :: nsmpchunks + + ! maximum number of columns assigned to a chunk in a given virtual SMP node (0:nsmpx-1) + integer, dimension(:), allocatable :: maxcol_chk + + ! number of chunks in given virtual SMP node receiving maximum number of columns + ! (0:nsmpx-1) + integer, dimension(:), allocatable :: maxcol_chks + + ! chunk id virtual offset (0:nsmpx-1) + integer, dimension(:), allocatable :: cid_offset + + ! process-local chunk id (0:nsmpx-1) + integer, dimension(:), allocatable :: local_cid + +#if ( defined _OPENMP ) + integer omp_get_max_threads + external omp_get_max_threads +#endif + +!----------------------------------------------------------------------- +! +! Determine number of threads per process +! + nlthreads = 1 +#if ( defined _OPENMP ) + nlthreads = OMP_GET_MAX_THREADS() +#endif +! +#if ( defined SPMD ) + call mpiallgatherint(nlthreads, 1, npthreads, 1, mpicom) +#else + npthreads(0) = nlthreads + proc_smp_map(0) = 0 +#endif - end subroutine get_grid_dims +! +! Determine index range for dynamics blocks +! + call get_block_bounds_d(firstblock,lastblock) + +! +! Determine maximum number of columns in a block +! + maxblksiz = 0 + do jb=firstblock,lastblock + maxblksiz = max(maxblksiz,get_block_gcol_cnt_d(jb)) + enddo + +! +! determine which (and how many) processes are assigned +! dynamics blocks +! + allocate( proc_busy_d(0:npes-1) ) + proc_busy_d = .false. + nproc_busy_d = 0 + do jb=firstblock,lastblock + p = get_block_owner_d(jb) + if (.not. proc_busy_d(p) ) then + proc_busy_d(p) = .true. + nproc_busy_d = nproc_busy_d + 1 + endif + enddo + +! +! Determine virtual SMP count and processes/virtual SMP map. +! If option 0 or >3, pretend that each SMP has only one process. +! If option 1, use SMP information. +! If option 2, pretend that all processes are in one SMP node. +! If option 3, pretend that each SMP node is made up of two +! processes, chosen to maximize load-balancing opportunities. +! +! For all options < 5, if there are "idle" dynamics processes, +! assign them to the virtual SMP nodes in wrap fashion. +! Communication between the active and idle dynamics +! processes is scatter/gather (no communications between +! idle dynamics processes) so there is no advantage to +! blocking the idle processes in these assignments. +! + if ((opt <= 0) .or. (opt == 4)) then + +! assign active dynamics processes to virtual SMP nodes + nsmpx = 0 + do p=0,npes-1 + if (proc_busy_d(p)) then + proc_smp_mapx(p) = nsmpx + nsmpx = nsmpx + 1 + endif + enddo +! +! assign idle dynamics processes to virtual SMP nodes (wrap map) + nsmpy = 0 + do p=0,npes-1 + if (.not. proc_busy_d(p)) then + proc_smp_mapx(p) = nsmpy + nsmpy = mod(nsmpy+1,nsmpx) + endif + enddo + + elseif (opt == 1) then + + allocate( smp_busy_d(0:nsmps-1) ) + allocate( smp_smp_mapx(0:nsmps-1) ) + +! +! determine SMP nodes assigned dynamics blocks + smp_busy_d = .false. + do p=0,npes-1 + if ( proc_busy_d(p) ) then + smp = proc_smp_map(p) + smp_busy_d(smp) = .true. + endif + enddo + +! +! determine number of SMP nodes assigned dynamics blocks + nsmpx = 0 + do smp=0,nsmps-1 + if (smp_busy_d(smp)) then + smp_smp_mapx(smp) = nsmpx + nsmpx = nsmpx + 1 + endif + enddo +! +! assign processes in active dynamics SMP nodes to virtual SMP nodes + do p=0,npes-1 + smp = proc_smp_map(p) + if (smp_busy_d(smp)) then + proc_smp_mapx(p) = smp_smp_mapx(smp) + endif + enddo +! +! assign processes in idle dynamics SMP nodes to virtual SMP nodes (wrap map) + nsmpy = 0 + do p=0,npes-1 + smp = proc_smp_map(p) + if (.not. smp_busy_d(smp)) then + proc_smp_mapx(p) = nsmpy + nsmpy = mod(nsmpy+1,nsmpx) + endif + enddo +! + deallocate( smp_busy_d ) + deallocate( smp_smp_mapx ) + + elseif (opt == 2) then + + nsmpx = 1 + do p=0,npes-1 + proc_smp_mapx(p) = 0 + enddo + + elseif (opt == 3) then - !======================================================================== - - ! Note: This routine is a stub for future load-balancing - subroutine phys_decomp_to_dyn() - !----------------------------------------------------------------------- - ! - ! phys_decomp_to_dyn: Transfer physics data to dynamics decomp - ! - !----------------------------------------------------------------------- - end subroutine phys_decomp_to_dyn - - !======================================================================== - - ! Note: This routine is a stub for future load-balancing - subroutine dyn_decomp_to_phys() - !----------------------------------------------------------------------- - ! - ! dyn_decomp_to_phys: Transfer dynamics data to physics decomp - ! - !----------------------------------------------------------------------- - - end subroutine dyn_decomp_to_phys - - !======================================================================== - - subroutine dump_grid_map(grid_map) - use spmd_utils, only: iam, npes, mpicom - use cam_grid_support, only: iMap - - integer(iMap), pointer :: grid_map(:,:) - - integer :: num_cols - integer :: penum, icol - logical :: unstruct - integer :: file - integer :: ierr - - unstruct = SIZE(grid_map, 1) == 3 - num_cols = SIZE(grid_map, 2) - if (iam == 0) then - open(newunit=file, file='physgrid_map.csv', status='replace') - if (unstruct) then - write(file, *) '"iam","col","block","map pos"' +! find active process partners + proc_smp_mapx = -1 + call find_partners(opt,proc_busy_d,nsmpx,proc_smp_mapx) +! +! assign unassigned (idle dynamics) processes to virtual SMP nodes +! (wrap map) + nsmpy = 0 + do p=0,npes-1 + if (proc_smp_mapx(p) == -1) then + proc_smp_mapx(p) = nsmpy + nsmpy = mod(nsmpy+1,nsmpx) + endif + enddo + + else + + nsmpx = npes + do p=0,npes-1 + proc_smp_mapx(p) = p + enddo + + endif +! + deallocate( proc_busy_d ) + +! +! Determine maximum number of processes assigned to a single +! virtual SMP node +! + allocate( nsmpprocs(0:nsmpx-1) ) +! + nsmpprocs(:) = 0 + do p=0,npes-1 + smp = proc_smp_mapx(p) + nsmpprocs(smp) = nsmpprocs(smp) + 1 + enddo + max_nproc_smpx = maxval(nsmpprocs) +! + deallocate( nsmpprocs ) + +! +! Determine number of columns assigned to each +! virtual SMP in block decomposition + + allocate( col_smp_mapx(ngcols) ) +! + col_smp_mapx(:) = -1 + error = .false. + do i=1,num_global_phys_cols + curgcol = latlon_to_dyn_gcol_map(i) + block_cnt = get_gcol_block_cnt_d(curgcol) + call get_gcol_block_d(curgcol,block_cnt,blockids,bcids) + do jb=1,block_cnt + p = get_block_owner_d(blockids(jb)) + if (col_smp_mapx(i) == -1) then + col_smp_mapx(i) = proc_smp_mapx(p) + elseif (col_smp_mapx(i) /= proc_smp_mapx(p)) then + error = .true. + endif + enddo + end do + if (error) then + write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & + "but vertical decomposition not limited to virtual SMP" + call endrun() + endif +! + allocate( nsmpcolumns(0:nsmpx-1) ) + nsmpcolumns(:) = 0 + do i=1,num_global_phys_cols + curgcol = latlon_to_dyn_gcol_map(i) + smp = col_smp_mapx(curgcol) + nsmpcolumns(smp) = nsmpcolumns(smp) + 1 + end do +! + deallocate( col_smp_mapx ) + +! +! Allocate other work space +! + allocate( nsmpthreads(0:nsmpx-1) ) + allocate( nsmpchunks (0:nsmpx-1) ) + allocate( maxcol_chk (0:nsmpx-1) ) + allocate( maxcol_chks(0:nsmpx-1) ) + allocate( cid_offset (0:nsmpx-1) ) + allocate( local_cid (0:nsmpx-1) ) + allocate( cols(1:maxblksiz) ) +! +! Options 0-3: split local dynamics blocks into chunks, +! using wrap-map assignment of columns and +! day/night and north/south column pairs +! to chunks to improve load balance +! Option 0: local is per process +! Option 1: local is subset of`processes assigned to same SMP node +! Option 2: local is global +! Option 3: local is pair of processes chosen to maximize load-balance +! wrt restriction that only communicate with one other +! process. +! Option 4: split local dynamics blocks into chunks, +! using block-map assignment of columns +! + if ((opt >= 0) .and. (opt <= 4)) then +! +! Calculate number of threads available in each SMP node. +! + nsmpthreads(:) = 0 + do p=0,npes-1 + smp = proc_smp_mapx(p) + nsmpthreads(smp) = nsmpthreads(smp) + npthreads(p) + enddo +! +! Determine number of chunks to keep all threads busy +! + nchunks = 0 + do smp=0,nsmpx-1 + nsmpchunks(smp) = nsmpcolumns(smp)/pcols + if (mod(nsmpcolumns(smp), pcols) /= 0) then + nsmpchunks(smp) = nsmpchunks(smp) + 1 + endif + if (nsmpchunks(smp) < chunks_per_thread*nsmpthreads(smp)) then + nsmpchunks(smp) = chunks_per_thread*nsmpthreads(smp) + endif + do while (mod(nsmpchunks(smp), nsmpthreads(smp)) /= 0) + nsmpchunks(smp) = nsmpchunks(smp) + 1 + enddo + if (nsmpchunks(smp) > nsmpcolumns(smp)) then + nsmpchunks(smp) = nsmpcolumns(smp) + endif + nchunks = nchunks + nsmpchunks(smp) + enddo +! +! Determine maximum number of columns to assign to chunks +! in a given SMP +! + do smp=0,nsmpx-1 + if (nsmpchunks(smp) /= 0) then + ntmp1 = nsmpcolumns(smp)/nsmpchunks(smp) + ntmp2 = mod(nsmpcolumns(smp),nsmpchunks(smp)) + if (ntmp2 > 0) then + maxcol_chk(smp) = ntmp1 + 1 + maxcol_chks(smp) = ntmp2 + else + maxcol_chk(smp) = ntmp1 + maxcol_chks(smp) = nsmpchunks(smp) + endif else - write(file, *) '"iam","col","block","lon","lat"' - end if - close(unit=file) - end if - do penum = 0, npes - 1 - if (iam == penum) then - open(newunit=file, file='physgrid_map.csv', status='old', & - action='readwrite', position='append') - do icol = 1, num_cols - if (unstruct) then - write(file, '(3(i0,","),i0)') iam, int(grid_map(1,icol)), & - int(grid_map(2,icol)), int(grid_map(3,icol)) + maxcol_chk(smp) = 0 + maxcol_chks(smp) = 0 + endif + enddo +! +! Allocate chunks and knuhcs data structures +! + allocate( chunks(1:nchunks) ) + allocate( knuhcs(1:ngcols) ) +! +! Initialize chunks and knuhcs data structures +! + chunks(:)%ncols = 0 + knuhcs(:)%chunkid = -1 + knuhcs(:)%col = -1 +! +! Determine chunk id ranges for each SMP +! + cid_offset(0) = 1 + local_cid(0) = 0 + do smp=1,nsmpx-1 + cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) + local_cid(smp) = 0 + enddo +! +! Assign columns to chunks +! + do jb=firstblock,lastblock + p = get_block_owner_d(jb) + smp = proc_smp_mapx(p) + blksiz = get_block_gcol_cnt_d(jb) + call get_block_gcol_d(jb,blksiz,cols) + do ib = 1,blksiz +! +! Assign column to a chunk if not already assigned + curgcol = cols(ib) + if ((dyn_to_latlon_gcol_map(curgcol) /= -1) .and. & + (knuhcs(curgcol)%chunkid == -1)) then +! +! Find next chunk with space +! (maxcol_chks > 0 test necessary for opt=4 block map) + cid = cid_offset(smp) + local_cid(smp) + if (maxcol_chks(smp) > 0) then + do while (chunks(cid)%ncols >= maxcol_chk(smp)) + local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) + cid = cid_offset(smp) + local_cid(smp) + enddo else - write(file, '(4(i0,","),i0)') iam, int(grid_map(1,icol)), & - int(grid_map(2,icol)), int(grid_map(3,icol)), & - int(grid_map(4,icol)) - end if - end do - close(unit=file) - end if - call MPI_barrier(mpicom, ierr) - end do - end subroutine dump_grid_map + do while (chunks(cid)%ncols >= maxcol_chk(smp)-1) + local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) + cid = cid_offset(smp) + local_cid(smp) + enddo + endif + chunks(cid)%ncols = chunks(cid)%ncols + 1 + if (chunks(cid)%ncols == maxcol_chk(smp)) & + maxcol_chks(smp) = maxcol_chks(smp) - 1 +! + i = chunks(cid)%ncols + chunks(cid)%gcol(i) = curgcol + chunks(cid)%lon(i) = lon_p(curgcol) + chunks(cid)%lat(i) = lat_p(curgcol) + knuhcs(curgcol)%chunkid = cid + knuhcs(curgcol)%col = i +! + if (opt < 4) then +! +! If space available, look to assign a load-balancing "twin" to same chunk + if ( (chunks(cid)%ncols < maxcol_chk(smp)) .and. & + (maxcol_chks(smp) > 0) .and. (twin_alg > 0)) then -!============================================================================= -!== -!!!!!! DUMMY INTERFACEs TO TEST WEAK SCALING INFRASTRUCTURE, SHOULD GO AWAY -!== -!============================================================================= + call find_twin(curgcol, smp, & + proc_smp_mapx, twingcol) - subroutine scatter_field_to_chunk(fdim,mdim,ldim, & - hdim1d,globalfield,localchunks) - use cam_abortutils, only: endrun - use ppgrid, only: pcols - !----------------------------------------------------------------------- - ! - ! Purpose: DUMMY FOR WEAK SCALING TESTS - ! - !------------------------------Arguments-------------------------------- - integer, intent(in) :: fdim ! declared length of first dimension - integer, intent(in) :: mdim ! declared length of middle dimension - integer, intent(in) :: ldim ! declared length of last dimension - integer, intent(in) :: hdim1d ! declared first horizontal index - real(r8), intent(in) :: globalfield(fdim,hdim1d,mdim,hdim2_d,ldim) - real(r8), intent(out):: localchunks(fdim,pcols,mdim, & - begchunk:endchunk,ldim) - - call endrun('scatter_field_to_chunk: NOT SUPPORTED WITH WEAK SCALING') - end subroutine scatter_field_to_chunk + if (twingcol > 0) then + chunks(cid)%ncols = chunks(cid)%ncols + 1 + if (chunks(cid)%ncols == maxcol_chk(smp)) & + maxcol_chks(smp) = maxcol_chks(smp) - 1 +! + i = chunks(cid)%ncols + chunks(cid)%gcol(i) = twingcol + chunks(cid)%lon(i) = lon_p(twingcol) + chunks(cid)%lat(i) = lat_p(twingcol) + knuhcs(twingcol)%chunkid = cid + knuhcs(twingcol)%col = i + endif +! + endif +! +! Move on to next chunk (wrap map) + local_cid(smp) = mod(local_cid(smp)+1,nsmpchunks(smp)) +! + endif +! + endif + enddo + enddo +! + else +! +! Option 5: split individual dynamics blocks into chunks, +! assigning consecutive columns to the same chunk +! +! Determine total number of chunks and +! number of chunks in each "SMP node" +! (assuming no vertical decomposition) + nchunks = 0 + nsmpchunks(:) = 0 + do j=firstblock,lastblock + blksiz = get_block_gcol_cnt_d(j) + nlchunks = blksiz/pcols + if (pcols*(blksiz/pcols) /= blksiz) then + nlchunks = nlchunks + 1 + endif + nchunks = nchunks + nlchunks + p = get_block_owner_d(j) + nsmpchunks(p) = nsmpchunks(p) + nlchunks + enddo +! +! Determine chunk id ranges for each SMP +! + cid_offset(0) = 1 + local_cid(0) = 0 + do smp=1,nsmpx-1 + cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) + local_cid(smp) = 0 + enddo +! +! Allocate chunks and knuhcs data structures +! + allocate( chunks(1:nchunks) ) + allocate( knuhcs(1:ngcols) ) +! +! Initialize chunks and knuhcs data structures +! + knuhcs(:)%chunkid = -1 + knuhcs(:)%col = -1 + cid = 0 + do jb=firstblock,lastblock + p = get_block_owner_d(jb) + smp = proc_smp_mapx(p) + blksiz = get_block_gcol_cnt_d(jb) + call get_block_gcol_d(jb,blksiz,cols) + + ib = 0 + do while (ib < blksiz) + + cid = cid_offset(smp) + local_cid(smp) + max_ncols = min(pcols,blksiz-ib) + + ncols = 0 + do i=1,max_ncols + ib = ib + 1 + ! check whether global index is for a column that dynamics + ! intends to pass to the physics + curgcol = cols(ib) + if (dyn_to_latlon_gcol_map(curgcol) /= -1) then + ! yes - then save the information + ncols = ncols + 1 + chunks(cid)%gcol(ncols) = curgcol + chunks(cid)%lon(ncols) = lon_p(curgcol) + chunks(cid)%lat(ncols) = lat_p(curgcol) + knuhcs(curgcol)%chunkid = cid + knuhcs(curgcol)%col = ncols + endif + enddo + chunks(cid)%ncols = ncols - !======================================================================== + local_cid(smp) = local_cid(smp) + 1 + enddo + enddo +! +! Set number of threads available in each "SMP node". +! + do p=0,npes-1 + nsmpthreads(p) = npthreads(p) + enddo +! + endif +! +! Assign chunks to processes. +! + call assign_chunks(npthreads, nsmpx, proc_smp_mapx, & + nsmpthreads, nsmpchunks) +! +! Clean up +! + deallocate( nsmpcolumns ) + deallocate( nsmpthreads ) + deallocate( nsmpchunks ) + deallocate( maxcol_chk ) + deallocate( maxcol_chks ) + deallocate( cid_offset ) + deallocate( local_cid ) + deallocate( cols ) + deallocate( knuhcs ) + + return + end subroutine create_chunks +! +!======================================================================== - subroutine get_lat_all_p_int(lcid, latdim, lats) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_lat_all_p: Return all latitudes (in degrees) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: latdim ! declared size of output array - integer, intent(out) :: lats(latdim) ! array of latitudes + subroutine find_partners(opt, proc_busy_d, nsmpx, proc_smp_mapx) +!----------------------------------------------------------------------- +! +! Purpose: Divide processes into pairs, attempting to maximize the +! the number of columns in one process whose twins are in the +! other process. +! +! Method: The day/night and north/south hemisphere complement is defined +! to be the column twin. +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use dyn_grid, only: get_gcol_block_cnt_d, get_gcol_block_d, & + get_block_owner_d + use pmgrid, only: plev +!------------------------------Arguments-------------------------------- + integer, intent(in) :: opt ! chunking option + logical, intent(in) :: proc_busy_d(0:npes-1) + ! active/idle dynamics process flags + integer, intent(out) :: nsmpx ! calculated number of virtual + ! SMP nodes + integer, intent(out) :: proc_smp_mapx(0:npes-1) + ! process/virtual smp map +!---------------------------Local workspace----------------------------- + integer :: gcol_latlon ! physics column index (latlon sorted) + integer :: twingcol_latlon ! physics column index (latlon sorted) + integer :: gcol, twingcol ! physics column indices + integer :: lon, lat, twinlat ! longitude and latitude indices + integer :: twinlon_off ! estimate as to offset of twinlon + ! on a latitude line + integer :: block_cnt ! number of blocks containing data + ! for a given vertical column + integer :: blockids(plev+1) ! block indices + integer :: bcids(plev+1) ! block column indices + integer :: jb ! block index + integer :: p, twp ! process indices + integer :: col_proc_mapx(ngcols) ! location of columns in + ! dynamics decomposition + integer :: twin_proc_mapx(ngcols) ! location of column twins in + ! dynamics decomposition + integer :: twin_cnt(0:npes-1) ! for each process, number of twins + ! in each of the other processes + logical :: assigned(0:npes-1) ! flag indicating whether process + ! assigned to an SMP node yet + integer :: maxpartner, maxcnt ! process with maximum number of + ! twins and this count + + logical :: error ! error flag +!----------------------------------------------------------------------- +! +! Determine process location of column and its twin in dynamics decomposition +! + col_proc_mapx(:) = -1 + twin_proc_mapx(:) = -1 + + error = .false. + do gcol_latlon=1,num_global_phys_cols + + ! Assume latitude and longitude symmetries and that index manipulations + ! are sufficient to find partners. (Will be true for lon/lat grids.) + gcol = latlon_to_dyn_gcol_map(gcol_latlon) + lat = lat_p(gcol) + twinlat = clat_p_tot+1-lat + lon = lon_p(gcol) + twinlon_off = mod((lon-1)+(clat_p_cnt(twinlat)/2), clat_p_cnt(twinlat)) + twingcol_latlon = clat_p_idx(twinlat) + twinlon_off + twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) + + block_cnt = get_gcol_block_cnt_d(gcol) + call get_gcol_block_d(gcol,block_cnt,blockids,bcids) + do jb=1,block_cnt + p = get_block_owner_d(blockids(jb)) + if (col_proc_mapx(gcol) == -1) then + col_proc_mapx(gcol) = p + elseif (col_proc_mapx(gcol) /= p) then + error = .true. + endif + enddo + + block_cnt = get_gcol_block_cnt_d(twingcol) + call get_gcol_block_d(twingcol,block_cnt,blockids,bcids) + do jb=1,block_cnt + p = get_block_owner_d(blockids(jb)) + if (twin_proc_mapx(gcol) == -1) then + twin_proc_mapx(gcol) = p + elseif (twin_proc_mapx(gcol) /= p) then + error = .true. + endif + enddo + + end do + + if (error) then + if (masterproc) then + write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & + "but vertical decomposition not limited to single process" + endif + call endrun() + endif - call endrun('get_lat_all_p: deprecated interface') +! +! Assign process pairs to SMPs, attempting to maximize the number of column,twin +! pairs in same SMP. +! + assigned(:) = .false. + twin_cnt(:) = 0 + nsmpx = 0 + do p=0,npes-1 + if ((.not. assigned(p)) .and. (proc_busy_d(p))) then +! +! For each process, determine number of twins in each of the other processes +! (running over all columns multiple times to minimize memory requirements). +! + do gcol_latlon=1,num_global_phys_cols + gcol = latlon_to_dyn_gcol_map(gcol_latlon) + if (col_proc_mapx(gcol) == p) then + twin_cnt(twin_proc_mapx(gcol)) = & + twin_cnt(twin_proc_mapx(gcol)) + 1 + endif + enddo +! +! Find process with maximum number of twins that has not yet been designated +! a partner. +! + maxpartner = -1 + maxcnt = 0 + do twp=0,npes-1 + if ((.not. assigned(twp)) .and. (twp /= p)) then + if (twin_cnt(twp) >= maxcnt) then + maxcnt = twin_cnt(twp) + maxpartner = twp + endif + endif + enddo +! +! Assign p and twp to the same SMP node +! + if (maxpartner /= -1) then + assigned(p) = .true. + assigned(maxpartner) = .true. + proc_smp_mapx(p) = nsmpx + proc_smp_mapx(maxpartner) = nsmpx + nsmpx = nsmpx + 1 + else + if (masterproc) then + write(iulog,*) "PHYS_GRID_INIT error: opt", opt, "specified, ", & + "but could not divide processes into pairs." + endif + call endrun() + endif +! + endif +! + enddo +! + return + end subroutine find_partners +! +!======================================================================== - end subroutine get_lat_all_p_int + subroutine find_twin(gcol, smp, proc_smp_mapx, twingcol_f) +!----------------------------------------------------------------------- +! +! Purpose: Find column that when paired with gcol in a chunk +! balances the load. A column is a candidate to be paired with +! gcol if it is in the same SMP node as gcol as defined +! by proc_smp_mapx. +! +! Method: The day/night and north/south hemisphere complement is +! tried first. If it is not a candidate or if it has already been +! assigned, then the day/night complement is tried next. If that +! also is not available, then nothing is returned. +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use dyn_grid, only: get_gcol_block_d, get_block_owner_d + +!------------------------------Arguments-------------------------------- + integer, intent(in) :: gcol ! global column index for column + ! seeking a twin for + integer, intent(in) :: smp ! index of SMP node + ! currently assigned to + integer, intent(in) :: proc_smp_mapx(0:npes-1) + ! process/virtual smp map + integer, intent(out) :: twingcol_f + ! global column index for twin +!---------------------------Local workspace----------------------------- + integer :: lon, lat ! global lon/lat indices for column + ! seeking a twin for + integer :: twinlon, twinlat ! lon/lat indices of twin candidate + integer :: twinlon_off ! estimate as to offset of twinlon + ! on a latitude line + logical :: found ! found flag + integer :: i ! loop index + integer :: upper, lower ! search temporaries + integer :: twingcol_latlon ! global physics column index (latlon sorted) + integer :: twingcol_lonlat ! global physics column index (lonlat sorted) + integer :: twingcol ! global physics column indes + integer :: diff, min_diff, min_i ! search temporaries + integer :: jbtwin(npes) ! global block indices + integer :: ibtwin(npes) ! global column indices + integer :: twinproc, twinsmp ! process and smp ids + + integer :: clon_p_idx(clon_p_tot) ! index in lonlat ordering for first + ! occurrence of longitude corresponding to + ! given latitude index + + real(r8):: twopi ! 2*pi + real(r8):: clat, twinclat ! latitude and twin + real(r8):: clon, twinclon ! longitude and twin + +!----------------------------------------------------------------------- + twingcol_f = -1 + + ! precompute clon_p_idx + clon_p_idx(1) = 1 + do i=2,clon_p_tot + clon_p_idx(i) = clon_p_idx(i-1) + clon_p_cnt(i-1) + enddo +! +! Try day/night and north/south hemisphere complement first +! + ! determine twin latitude + lat = lat_p(gcol) + clat = clat_p(lat) + twinclat = -clat + twinlat = clat_p_tot+1-lat + if (clat_p(twinlat) == twinclat) then + found = .true. + else + found = .false. + upper = twinlat + lower = twinlat + if (upper < clat_p_tot) upper = twinlat + 1 + if (lower > 1) lower = twinlat - 1 + endif + do while (.not. found) + if ((abs(clat_p(upper)-twinclat) < abs(clat_p(twinlat)-twinclat)) .and. & + (upper /= twinlat)) then + twinlat = upper + if (upper < clat_p_tot) then + upper = twinlat + 1 + else + found = .true. + endif + else if ((abs(clat_p(lower)-twinclat) < abs(clat_p(twinlat)-twinclat)) .and. & + (lower /= twinlat)) then + twinlat = lower + if (lower > 1) then + lower = twinlat - 1 + else + found = .true. + endif + else + found = .true. + endif + enddo + + ! determine twin longitude + twopi = 2.0_r8*pi + lon = lon_p(gcol) + clon = clon_p(lon) + twinclon = mod(clon+pi,twopi) + twinlon = mod((lon-1)+(clon_p_tot/2), clon_p_tot) + 1 + if (clon_p(twinlon) == twinclon) then + found = .true. + else + found = .false. + upper = twinlon + lower = twinlon + if (upper < clon_p_tot) upper = twinlon + 1 + if (lower > 1) lower = twinlon - 1 + endif + do while (.not. found) + if ((abs(clon_p(upper)-twinclon) < abs(clon_p(twinlon)-twinclon)) .and. & + (upper /= twinlon)) then + twinlon = upper + if (upper < clon_p_tot) then + upper = twinlon + 1 + else + found = .true. + endif + else if ((abs(clon_p(lower)-twinclon) < abs(clon_p(twinlon)-twinclon)) .and. & + (lower /= twinlon)) then + twinlon = lower + if (lower > 1) then + lower = twinlon - 1 + else + found = .true. + endif + else + found = .true. + endif + enddo + + ! first, look for an exact match (assuming latitude and longitude symmetries) + twinlon_off = mod((lon-1)+(clat_p_cnt(twinlat)/2), clat_p_cnt(twinlat)) + twingcol_latlon = clat_p_idx(twinlat) + twinlon_off + twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) + + ! otherwise, look around for an approximate match using lonlat sorted indices + if ((lon_p(twingcol) /= twinlon) .or. (lat_p(twingcol) /= twinlat)) then + twingcol_lonlat = clon_p_idx(twinlon) + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + min_diff = abs(lat_p(twingcol) - twinlat) + min_i = 0 + do i = 1, clon_p_cnt(twinlon)-1 + twingcol_lonlat = clon_p_idx(twinlon)+i + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + diff = abs(lat_p(twingcol) - twinlat) + if (diff < min_diff) then + min_diff = diff + min_i = i + endif + enddo + twingcol_lonlat = clon_p_idx(twinlon) + min_i + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + endif + + ! Check whether twin and original are in same smp + found = .false. + call get_gcol_block_d(twingcol,npes,jbtwin,ibtwin) + twinproc = get_block_owner_d(jbtwin(1)) + twinsmp = proc_smp_mapx(twinproc) +! + if ((twinsmp == smp) .and. & + (knuhcs(twingcol)%chunkid == -1)) then + found = .true. + twingcol_f = twingcol + endif +! +! Try day/night complement next + if (.not. found) then + + ! first, look for an exact match (assuming longitude symmetries) + twinlon_off = mod((lon-1)+(clat_p_cnt(lat)/2), clat_p_cnt(lat)) + twingcol_latlon = clat_p_idx(lat) + twinlon_off + twingcol = latlon_to_dyn_gcol_map(twingcol_latlon) + + ! otherwise, look around for an approximate match using lonlat + ! column ordering + if ((lon_p(twingcol) /= twinlon) .or. & + (lat_p(twingcol) /= lat)) then + twingcol_lonlat = clon_p_idx(twinlon) + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + min_diff = abs(lat_p(twingcol) - lat) + min_i = 0 + do i = 1, clon_p_cnt(twinlon)-1 + twingcol_lonlat = clon_p_idx(twinlon)+i + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + diff = abs(lat_p(twingcol) - lat) + if (diff < min_diff) then + min_diff = diff + min_i = i + endif + enddo + twingcol_lonlat = clon_p_idx(twinlon) + min_i + twingcol = lonlat_to_dyn_gcol_map(twingcol_lonlat) + endif +! + call get_gcol_block_d(twingcol,npes,jbtwin,ibtwin) + twinproc = get_block_owner_d(jbtwin(1)) + twinsmp = proc_smp_mapx(twinproc) +! + if ((twinsmp == smp) .and. & + (knuhcs(twingcol)%chunkid == -1)) then + found = .true. + twingcol_f = twingcol + endif +! + endif +! + return + end subroutine find_twin +! +!======================================================================== - !======================================================================== + subroutine assign_chunks(npthreads, nsmpx, proc_smp_mapx, & + nsmpthreads, nsmpchunks) +!----------------------------------------------------------------------- +! +! Purpose: Assign chunks to processes, balancing the number of +! chunks per thread and minimizing the communication costs +! in dp_coupling subject to the restraint that columns +! do not migrate outside of the current SMP node. +! +! Method: +! +! Author: Patrick Worley +! +!----------------------------------------------------------------------- + use pmgrid, only: plev + use dyn_grid, only: get_gcol_block_cnt_d, get_gcol_block_d,& + get_block_owner_d +!------------------------------Arguments-------------------------------- + integer, intent(in) :: npthreads(0:npes-1) + ! number of OpenMP threads per process + integer, intent(in) :: nsmpx ! virtual smp count + integer, intent(in) :: proc_smp_mapx(0:npes-1) + ! process/virtual smp map + integer, intent(in) :: nsmpthreads(0:nsmpx-1) + ! number of OpenMP threads + ! per virtual SMP + integer, intent(in) :: nsmpchunks(0:nsmpx-1) + ! number of chunks assigned + ! to a given virtual SMP +!---------------------------Local workspace----------------------------- + integer :: i, jb, p ! loop indices + integer :: cid ! chunk id + integer :: smp ! SMP index + integer :: curgcol ! global column index + integer :: block_cnt ! number of blocks containing data + ! for a given vertical column + integer :: blockids(plev+1) ! block indices + integer :: bcids(plev+1) ! block column indices + integer :: ntsks_smpx(0:nsmpx-1) ! number of processes per virtual SMP + integer :: smp_proc_mapx(0:nsmpx-1,max_nproc_smpx) + ! virtual smp to process id map + integer :: cid_offset(0:nsmpx) ! chunk id virtual smp offset + integer :: ntmp1_smp(0:nsmpx-1) ! minimum number of chunks per thread + ! in a virtual SMP + integer :: ntmp2_smp(0:nsmpx-1) ! number of extra chunks to be assigned + ! in a virtual SMP + integer :: ntmp3_smp(0:nsmpx-1) ! number of processes in a virtual + ! SMP that get more extra chunks + ! than the others + integer :: ntmp4_smp(0:nsmpx-1) ! number of extra chunks per process + ! in a virtual SMP + integer :: ntmp1, ntmp2 ! work variables +! integer :: npchunks(0:npes-1) ! number of chunks to be assigned to +! ! a given process + integer :: cur_npchunks(0:npes-1) ! current number of chunks assigned + ! to a given process + integer :: column_count(0:npes-1) ! number of columns from current chunk + ! assigned to each process in dynamics + ! decomposition +!----------------------------------------------------------------------- +! +! Count number of processes per virtual SMP and determine virtual SMP +! to process id map +! + ntsks_smpx(:) = 0 + smp_proc_mapx(:,:) = -1 + do p=0,npes-1 + smp = proc_smp_mapx(p) + ntsks_smpx(smp) = ntsks_smpx(smp) + 1 + smp_proc_mapx(smp,ntsks_smpx(smp)) = p + enddo +! +! Determine chunk id ranges for each virtual SMP +! + cid_offset(0) = 1 + do smp=1,nsmpx + cid_offset(smp) = cid_offset(smp-1) + nsmpchunks(smp-1) + enddo +! +! Determine number of chunks to assign to each process +! + do smp=0,nsmpx-1 +! +! Minimum number of chunks per thread + ntmp1_smp(smp) = nsmpchunks(smp)/nsmpthreads(smp) - subroutine get_lon_all_p_int(lcid, londim, lons) - use cam_abortutils, only: endrun - !----------------------------------------------------------------------- - ! - ! get_lon_all_p:: Return all longitudes (in degrees) for chunk, - ! - !----------------------------------------------------------------------- - ! Dummy Arguments - integer, intent(in) :: lcid ! local chunk id - integer, intent(in) :: londim ! declared size of output array - integer, intent(out) :: lons(londim) ! array of longitudes +! Number of extra chunks to be assigned + ntmp2_smp(smp) = mod(nsmpchunks(smp),nsmpthreads(smp)) + +! Number of processes that get more extra chunks than the others + ntmp3_smp(smp) = mod(ntmp2_smp(smp),ntsks_smpx(smp)) + +! Number of extra chunks per process + ntmp4_smp(smp) = ntmp2_smp(smp)/ntsks_smpx(smp) + if (ntmp3_smp(smp) > 0) then + ntmp4_smp(smp) = ntmp4_smp(smp) + 1 + endif + enddo - call endrun('get_lon_all_p: deprecated interface') + do p=0,npes-1 + smp = proc_smp_mapx(p) - end subroutine get_lon_all_p_int +! Update number of extra chunks + if (ntmp2_smp(smp) > ntmp4_smp(smp)) then + ntmp2_smp(smp) = ntmp2_smp(smp) - ntmp4_smp(smp) + else + ntmp4_smp(smp) = ntmp2_smp(smp) + ntmp2_smp(smp) = 0 + ntmp3_smp(smp) = 0 + endif + +! Set number of chunks + npchunks(p) = ntmp1_smp(smp)*npthreads(p) + ntmp4_smp(smp) + +! Update extra chunk increment + if (ntmp3_smp(smp) > 0) then + ntmp3_smp(smp) = ntmp3_smp(smp) - 1 + if (ntmp3_smp(smp) == 0) then + ntmp4_smp(smp) = ntmp4_smp(smp) - 1 + endif + endif + enddo + +! +! Assign chunks to processes: +! + cur_npchunks(:) = 0 +! + do smp=0,nsmpx-1 + do cid=cid_offset(smp),cid_offset(smp+1)-1 +! + do i=1,ntsks_smpx(smp) + p = smp_proc_mapx(smp,i) + column_count(p) = 0 + enddo +! +! For each chunk, determine number of columns in each +! process within the dynamics. + do i=1,chunks(cid)%ncols + curgcol = chunks(cid)%gcol(i) + block_cnt = get_gcol_block_cnt_d(curgcol) + call get_gcol_block_d(curgcol,block_cnt,blockids,bcids) + do jb=1,block_cnt + p = get_block_owner_d(blockids(jb)) + column_count(p) = column_count(p) + 1 + enddo + enddo +! +! Eliminate processes that already have their quota of chunks + do i=1,ntsks_smpx(smp) + p = smp_proc_mapx(smp,i) + if (cur_npchunks(p) == npchunks(p)) then + column_count(p) = -1 + endif + enddo +! +! Assign chunk to process with most +! columns from chunk, from among those still available + ntmp1 = -1 + ntmp2 = -1 + do i=1,ntsks_smpx(smp) + p = smp_proc_mapx(smp,i) + if (column_count(p) > ntmp1) then + ntmp1 = column_count(p) + ntmp2 = p + endif + enddo + cur_npchunks(ntmp2) = cur_npchunks(ntmp2) + 1 + chunks(cid)%owner = ntmp2 + +! Update total number of columns assigned to this process + gs_col_num(ntmp2) = gs_col_num(ntmp2) + chunks(cid)%ncols +! + enddo +! + enddo +! + return + end subroutine assign_chunks +! +!======================================================================== - !======================================================================== +!####################################################################### end module phys_grid diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index b3d1169e9a..706b9dcdee 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -4,8 +4,11 @@ module physpkg ! ! Provides the interface to CAM physics package ! - ! Module contains reordered physics to accomodate CLUBB - ! Modified after original physpkg module, Dec 2021, A. Herrington + ! Revision history: + ! Aug 2005, E. B. Kluzek, Creation of module from physpkg subroutine + ! 2005-10-17 B. Eaton Add contents of inti.F90 to phys_init(). Add + ! initialization of grid info in phys_state. + ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 @@ -18,7 +21,7 @@ module physpkg use phys_grid, only: get_ncols_p use phys_gmean, only: gmean_mass use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols - use constituents, only: pcnst, cnst_name, cnst_get_ind + use constituents, only: pcnst, cnst_get_ind use camsrfexch, only: cam_out_t, cam_in_t use cam_control_mod, only: ideal_phys, adiabatic @@ -91,8 +94,7 @@ module physpkg integer :: dvcore_idx = 0 ! dvcore index in physics buffer integer :: dtcore_idx = 0 ! dtcore index in physics buffer integer :: dqcore_idx = 0 ! dqcore index in physics buffer - integer :: cmfmczm_idx = 0 ! Zhang-McFarlane convective mass fluxes - integer :: rliqbc_idx = 0 ! tphysbc reserve liquid + !======================================================================= contains !======================================================================= @@ -110,12 +112,14 @@ subroutine phys_register use cam_abortutils, only: endrun use physics_buffer, only: pbuf_init_time, pbuf_cam_snapshot_register use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol - use constituents, only: cnst_add, cnst_chk_dim + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_add, cnst_chk_dim use cam_control_mod, only: moist_physics use chemistry, only: chem_register use mo_lightning, only: lightning_register use cloud_fraction, only: cldfrc_register + use rk_stratiform, only: rk_stratiform_register use microp_driver, only: microp_driver_register use microp_aero, only: microp_aero_register use macrop_driver, only: macrop_driver_register @@ -125,10 +129,12 @@ subroutine phys_register use tracers, only: tracers_register use check_energy, only: check_energy_register use carma_intr, only: carma_register + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_register + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_register use ghg_data, only: ghg_data_register use vertical_diffusion, only: vd_register use convect_deep, only: convect_deep_register - use convect_diagnostics,only: convect_diagnostics_register + use convect_shallow, only: convect_shallow_register use radiation, only: radiation_register use co2_cycle, only: co2_register use flux_avg, only: flux_avg_register @@ -139,6 +145,7 @@ subroutine phys_register use prescribed_strataero,only: prescribed_strataero_register use prescribed_aero, only: prescribed_aero_register use prescribed_ghg, only: prescribed_ghg_register + use sslt_rebin, only: sslt_rebin_register use aoa_tracers, only: aoa_tracers_register use aircraft_emit, only: aircraft_emit_register use cam_diagnostics, only: diag_register @@ -149,6 +156,7 @@ subroutine phys_register use subcol, only: subcol_register use subcol_utils, only: is_subcol_on, subcol_get_scheme use dyn_comp, only: dyn_register + use spcam_drivers, only: spcam_register use offline_driver, only: offline_driver_reg use hemco_interface, only: HCOI_Chunk_Init use upper_bc, only: ubc_fixed_conc @@ -158,6 +166,7 @@ subroutine phys_register integer :: m ! loop index integer :: mm ! constituent index integer :: nmodes + logical :: has_fixed_ubc ! for upper bndy cond !----------------------------------------------------------------------- ! Get physics options @@ -184,11 +193,12 @@ subroutine phys_register ! Register water vapor. ! ***** N.B. ***** This must be the first call to cnst_add so that ! water vapor is constituent 1. + has_fixed_ubc = ubc_fixed_conc('Q') ! .false. if (moist_physics) then - call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & + call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, fixed_ubc=has_fixed_ubc, & longname='Specific humidity', readiv=.true., is_convtran1=.true.) else - call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & + call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, fixed_ubc=has_fixed_ubc, & longname='Specific humidity', readiv=.false., is_convtran1=.true.) end if @@ -217,20 +227,24 @@ subroutine phys_register call cldfrc_register() ! cloud water - if (.not. do_clubb_sgs) call macrop_driver_register() - call microp_aero_register() - call microp_driver_register() + if( microp_scheme == 'RK' ) then + call rk_stratiform_register() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_register() + call microp_aero_register() + call microp_driver_register() + end if ! Register CLUBB_SGS here if (do_clubb_sgs) call clubb_register_cam() - call pbuf_add_field('PREC_STR', 'global',dtype_r8,(/pcols/),prec_str_idx) - call pbuf_add_field('SNOW_STR', 'global',dtype_r8,(/pcols/),snow_str_idx) - call pbuf_add_field('PREC_PCW', 'global',dtype_r8,(/pcols/),prec_pcw_idx) - call pbuf_add_field('SNOW_PCW', 'global',dtype_r8,(/pcols/),snow_pcw_idx) - call pbuf_add_field('PREC_SED', 'global',dtype_r8,(/pcols/),prec_sed_idx) - call pbuf_add_field('SNOW_SED', 'global',dtype_r8,(/pcols/),snow_sed_idx) + call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) + call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) + call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) + call pbuf_add_field('SNOW_PCW', 'physpkg',dtype_r8,(/pcols/),snow_pcw_idx) + call pbuf_add_field('PREC_SED', 'physpkg',dtype_r8,(/pcols/),prec_sed_idx) + call pbuf_add_field('SNOW_SED', 'physpkg',dtype_r8,(/pcols/),snow_sed_idx) if (is_subcol_on()) then call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) @@ -240,9 +254,6 @@ subroutine phys_register call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) end if - ! Reserve liquid at end of tphysbc - call pbuf_add_field('RLIQBC','physpkg',dtype_r8,(/pcols/),rliqbc_idx) - ! Who should add FRACIS? ! -- It does not seem that aero_intr should add it since FRACIS is used in convection ! even if there are no prognostic aerosols ... so do it here for now @@ -262,18 +273,27 @@ subroutine phys_register ! register chemical constituents including aerosols ... call chem_register() - ! add prognostic lightning flash freq pbuf fld + ! add prognostic lightning flash freq pbuf fld call lightning_register() ! co2 constituents call co2_register() - ! register other constituents + ! register data model ozone with pbuf + if (cam3_ozone_data_on) then + call cam3_ozone_data_register() + end if call prescribed_volcaero_register() call prescribed_strataero_register() call prescribed_ozone_register() call prescribed_aero_register() call prescribed_ghg_register() + call sslt_rebin_register + + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) then + call cam3_aero_data_register() + end if ! register various data model gasses with pbuf call ghg_data_register() @@ -295,8 +315,11 @@ subroutine phys_register ! deep convection call convect_deep_register - ! convection diagnostics - call convect_diagnostics_register + ! shallow convection + call convect_shallow_register + + + call spcam_register ! radiation call radiation_register @@ -366,11 +389,10 @@ subroutine phys_inidat( cam_out, pbuf2d ) type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) type(physics_buffer_desc), pointer :: pbuf2d(:,:) - integer :: lchnk, m, n, i, k, ncol + integer :: lchnk, m, n, ncol type(file_desc_t), pointer :: fh_ini, fh_topo character(len=8) :: fieldname real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) - real(r8), pointer :: qpert(:,:) character(len=11) :: subname='phys_inidat' ! subroutine name integer :: tpert_idx, qpert_idx, pblh_idx @@ -395,10 +417,7 @@ subroutine phys_inidat( cam_out, pbuf2d ) end if call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - allocate(tptr(1:pcols,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr(1:pcols,begchunk:endchunk)') - end if + allocate(tptr(1:pcols,begchunk:endchunk)) if (associated(fh_topo) .and. .not. aqua_planet) then call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & @@ -407,10 +426,7 @@ subroutine phys_inidat( cam_out, pbuf2d ) call pbuf_set_field(pbuf2d, sgh_idx, tptr) - allocate(tptr_2(1:pcols,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr_2(1:pcols,begchunk:endchunk)') - end if + allocate(tptr_2(1:pcols,begchunk:endchunk)) call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & tptr_2, found, gridname='physgrid') if(found) then @@ -465,10 +481,7 @@ subroutine phys_inidat( cam_out, pbuf2d ) if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' end if - allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d_2(pcols,pcnst,begchunk:endchunk)') - end if + allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk)) tptr3d_2 = 0_r8 tptr3d_2(:,1,:) = tptr(:,:) @@ -495,10 +508,7 @@ subroutine phys_inidat( cam_out, pbuf2d ) ! 3-D fields ! - allocate(tptr3d(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') - end if + allocate(tptr3d(pcols,pver,begchunk:endchunk)) fieldname='CLOUD' m = pbuf_get_index('CLD') @@ -574,10 +584,7 @@ subroutine phys_inidat( cam_out, pbuf2d ) call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) end do else - allocate(tptr3d_2(pcols,pver,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d_2(pcols,pver,begchunk:endchunk)') - end if + allocate(tptr3d_2(pcols,pver,begchunk:endchunk)) call cnst_get_ind('CLDICE', ixcldice) call cnst_get_ind('CLDLIQ', ixcldliq) call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & @@ -610,6 +617,9 @@ subroutine phys_inidat( cam_out, pbuf2d ) end if end if + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + fieldname = 'TCWAT' m = pbuf_get_index(fieldname,ierr) if (m > 0) then @@ -631,26 +641,8 @@ subroutine phys_inidat( cam_out, pbuf2d ) end do end if - fieldname = 'CONCLD' - m = pbuf_get_index('CONCLD',ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - end if - deallocate(tptr3d) - allocate(tptr3d(pcols,pverp,begchunk:endchunk), stat=ierr) - if (ierr /= 0) then - call endrun(subname//': Failed to allocate tptr3d(pcols,pver,begchunk:endchunk)') - end if + allocate(tptr3d(pcols,pverp,begchunk:endchunk)) fieldname = 'TKE' m = pbuf_get_index( 'tke') @@ -687,6 +679,26 @@ subroutine phys_inidat( cam_out, pbuf2d ) if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' end if + deallocate(tptr3d) + allocate(tptr3d(pcols,pver,begchunk:endchunk)) + + fieldname = 'CONCLD' + m = pbuf_get_index('CONCLD',ierr) + if (m > 0) then + call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & + tptr3d, found, gridname='physgrid') + if(found) then + do n = 1, dyn_time_lvls + call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) + end do + else + call pbuf_set_field(pbuf2d, m, 0._r8) + if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' + end if + + deallocate (tptr3d) + end if + call initialize_short_lived_species(fh_ini, pbuf2d) !--------------------------------------------------------------------------------- @@ -707,8 +719,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) !----------------------------------------------------------------------- use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index - use physconst, only: rair, cpair, gravit, zvir, & - karman + use physconst, only: rair, cpair, gravit, zvir, karman use cam_thermo, only: cam_thermo_init use ref_pres, only: pref_edge, pref_mid @@ -728,24 +739,27 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use cldfrc2m, only: cldfrc2m_init use co2_cycle, only: co2_init, co2_transport use convect_deep, only: convect_deep_init - use convect_diagnostics,only: convect_diagnostics_init + use convect_shallow, only: convect_shallow_init use cam_diagnostics, only: diag_init use gw_drag, only: gw_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_init use radheat, only: radheat_init use radiation, only: radiation_init use cloud_diagnostics, only: cloud_diagnostics_init + use rk_stratiform, only: rk_stratiform_init use wv_saturation, only: wv_sat_init use microp_driver, only: microp_driver_init use microp_aero, only: microp_aero_init use macrop_driver, only: macrop_driver_init use conv_water, only: conv_water_init + use spcam_drivers, only: spcam_init use tracers, only: tracers_init use aoa_tracers, only: aoa_tracers_init use rayleigh_friction, only: rayleigh_friction_init use pbl_utils, only: pbl_utils_init use vertical_diffusion, only: vertical_diffusion_init use phys_debug_util, only: phys_debug_init - use phys_debug, only: phys_debug_state_init use rad_constituents, only: rad_cnst_init use aer_rad_props, only: aer_rad_props_init use subcol, only: subcol_init @@ -760,6 +774,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) use clubb_intr, only: clubb_ini_cam + use sslt_rebin, only: sslt_rebin_init use tropopause, only: tropopause_init use solar_data, only: solar_data_init use dadadj_cam, only: dadadj_init @@ -767,8 +782,9 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init use cam_history, only: addfld, register_vector_field, add_default - use cam_budget, only: cam_budget_init + use phys_control, only: phys_getopts use phys_grid_ctem, only: phys_grid_ctem_init + use cam_budget, only: cam_budget_init ! Input/output arguments type(physics_state), pointer :: phys_state(:) @@ -786,7 +802,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! temperature, water vapor, cloud ! ice, cloud liquid, U, V integer :: history_budget_histfile_num ! output history file number for budget fields - !----------------------------------------------------------------------- call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) @@ -838,6 +853,9 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) ! low level, so init it early. Must at least do this before radiation. call wv_sat_init + ! CAM3 prescribed aerosols + if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) + ! Initialize rad constituents and their properties call rad_cnst_init() call aer_rad_props_init() @@ -868,6 +886,9 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call co2_init() end if + ! CAM3 prescribed ozone + if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) + call gw_init() call rayleigh_friction_init() @@ -889,21 +910,30 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call radheat_init(pref_mid) - call convect_diagnostics_init + call convect_shallow_init(pref_edge, pbuf2d) call cldfrc_init() call cldfrc2m_init() call convect_deep_init(pref_edge) - if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) - call microp_aero_init(phys_state,pbuf2d) - call microp_driver_init(pbuf2d) - call conv_water_init + if( microp_scheme == 'RK' ) then + call rk_stratiform_init() + elseif( microp_scheme == 'MG' ) then + if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) + call microp_aero_init(phys_state,pbuf2d) + call microp_driver_init(pbuf2d) + call conv_water_init + elseif( microp_scheme == 'SPCAM_m2005') then + call conv_water_init + end if + ! initiate CLUBB within CAM if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) + call spcam_init(pbuf2d) + call qbo_init call lunar_tides_init() @@ -917,6 +947,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) #if ( defined OFFLINE_DYN ) call metdata_phys_init() #endif + call sslt_rebin_init() call tropopause_init() call dadadj_init() @@ -926,7 +957,6 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) snow_sh_idx = pbuf_get_index('SNOW_SH') dlfzm_idx = pbuf_get_index('DLFZM', ierr) - cmfmczm_idx = pbuf_get_index('CMFMC_DP', ierr) call phys_getopts(prog_modal_aero_out=prog_modal_aero) @@ -937,7 +967,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) if (clim_modal_aero) then ! If climate calculations are affected by prescribed modal aerosols, the - ! initialization routine for the dry mode radius calculation is called + ! the initialization routine for the dry mode radius calculation is called ! here. For prognostic MAM the initialization is called from ! modal_aero_initialize if (.not. prog_modal_aero) then @@ -1046,6 +1076,8 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) use time_manager, only: get_nstep use cam_diagnostics,only: diag_allocate, diag_physvar_ic use check_energy, only: check_energy_gmean + use phys_control, only: phys_getopts + use spcam_drivers, only: tphysbc_spcam use spmd_utils, only: mpicom use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate #if (defined BFB_CAM_SCAM_IOP ) @@ -1073,8 +1105,8 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) !---------------------------Local workspace----------------------------- ! integer :: c ! indices - integer :: ncol ! number of columns integer :: nstep ! current timestep number + logical :: use_spcam type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) call t_startf ('physpkg_st1') @@ -1128,6 +1160,8 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) call t_startf ('bc_physics') call t_adj_detailf(+1) + call phys_getopts( use_spcam_out = use_spcam) + !$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) do c=begchunk, endchunk ! @@ -1139,9 +1173,16 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) call t_stopf ('diag_physvar_ic') - call tphysbc (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) + if (use_spcam) then + call tphysbc_spcam (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + else + call tphysbc (ztodt, phys_state(c), & + phys_tend(c), phys_buffer_chunk, & + cam_out(c), cam_in(c) ) + end if + end do call t_adj_detailf(-1) @@ -1332,9 +1373,6 @@ subroutine tphysac (ztodt, cam_in, & ! Computes the following: ! ! o Aerosol Emission at Surface - ! o Stratiform Macro-Microphysics - ! o Wet Scavenging of Aerosol - ! o Radiation ! o Source-Sink for Advected Tracers ! o Symmetric Turbulence Scheme - Vertical Diffusion ! o Rayleigh Friction @@ -1346,18 +1384,24 @@ subroutine tphysac (ztodt, cam_in, & ! o Scale Dry Mass Energy !----------------------------------------------------------------------- use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx + use shr_kind_mod, only: r8 => shr_kind_r8 use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions use cam_diagnostics, only: diag_phys_tend_writeout use gw_drag, only: gw_tend use vertical_diffusion, only: vertical_diffusion_tend use rayleigh_friction, only: rayleigh_friction_tend - use physics_types, only: physics_dme_adjust, set_dry_to_wet, physics_state_check, & + use constituents, only: cnst_get_ind + use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & + physics_dme_adjust, set_dry_to_wet, physics_state_check, & dyn_te_idx use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X use aoa_tracers, only: aoa_tracers_timestep_tend - use physconst, only: rhoh2o + use physconst, only: rhoh2o, latvap,latice + use dyn_tests_utils, only: vc_dycore use aero_model, only: aero_model_drydep + use carma_intr, only: carma_emission_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_aerosol, carma_do_emission use check_energy, only: check_energy_chng, tot_energy_phys use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng use time_manager, only: get_nstep @@ -1371,36 +1415,14 @@ subroutine tphysac (ztodt, cam_in, & use iondrag, only: iondrag_calc, do_waccm_ions use perf_mod use flux_avg, only: flux_avg_run - use cam_history, only: hist_fld_active, outfld + use unicon_cam, only: unicon_cam_org_diags + use cam_history, only: outfld use qneg_module, only: qneg4 use co2_cycle, only: co2_cycle_set_ptend use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend use cam_snapshot, only: cam_snapshot_all_outfld_tphysac use cam_snapshot_common,only: cam_snapshot_ptend_outfld use lunar_tides, only: lunar_tides_tend - use ssatcontrail, only: ssatcontrail_d0 - use physics_types, only: physics_ptend_init, physics_ptend_sum, physics_ptend_scale - use microp_driver, only: microp_driver_tend - use microp_aero, only: microp_aero_run - use clubb_intr, only: clubb_tend_cam, clubb_emissions_cam - use subcol, only: subcol_gen, subcol_ptend_avg - use subcol_utils, only: subcol_ptend_copy, is_subcol_on - use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol - use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv - use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim - use micro_pumas_cam, only: massless_droplet_destroyer - use convect_deep, only: convect_deep_tend_2, deep_scheme_does_scav_trans - use cloud_diagnostics, only: cloud_diagnostics_calc - use radiation, only: radiation_tend - use tropopause, only: tropopause_output - use cam_diagnostics, only: diag_phys_writeout, diag_conv, diag_clip_tend_writeout - use aero_model, only: aero_model_wetdep - use physics_buffer, only: col_type_subcol - use check_energy, only: check_energy_timestep_init - use carma_intr, only: carma_wetdep_tend, carma_timestep_tend, carma_emission_tend - use carma_flags_mod, only: carma_do_aerosol, carma_do_emission, carma_do_detrain - use carma_flags_mod, only: carma_do_cldice, carma_do_cldliq, carma_do_wetdep - use dyn_tests_utils, only: vc_dycore use cam_thermo, only: cam_thermo_water_update use cam_budget, only: thermo_budget_history use dyn_tests_utils, only: vc_dycore, vc_height, vc_dry_pressure @@ -1417,75 +1439,23 @@ subroutine tphysac (ztodt, cam_in, & type(physics_buffer_desc), pointer :: pbuf(:) - type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes + type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes ! !---------------------------Local workspace----------------------------- ! - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps - type(physics_state) :: state_sc ! state for sub-columns - type(physics_ptend) :: ptend_sc ! ptend for sub-columns - type(physics_ptend) :: ptend_aero ! ptend for microp_aero - type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns - type(physics_tend) :: tend_sc ! tend for sub-columns - - integer :: nstep ! current timestep number - real(r8) :: zero(pcols) ! array of zeros - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer i,k,m ! Longitude, level indices - integer :: yr, mon, day, tod ! components of a date - integer :: ixq, ixcldice, ixcldliq ! constituent indices for vapor, cloud liquid and ice water. - - ! for macro/micro co-substepping - integer :: macmic_it ! iteration variables - real(r8) :: cld_macmic_ztodt ! modified timestep - - real(r8) :: net_flx(pcols) - - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) rtdt ! 1./ztodt - - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice - real(r8) :: flx_cnd(pcols) - - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: zero_tracers(pcols,pcnst) - - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - real(r8), pointer :: cmfmczm(:,:) ! ZM convective mass fluxes - real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid - - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + type(physics_ptend) :: ptend ! indivdual parameterization tendencies - ! Local copies for substepping - real(r8) :: prec_pcw_macmic(pcols) - real(r8) :: snow_pcw_macmic(pcols) - real(r8) :: prec_sed_macmic(pcols) - real(r8) :: snow_sed_macmic(pcols) + integer :: nstep ! current timestep number + real(r8) :: zero(pcols) ! array of zeros - ! carma precipitation variables - real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) - real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i,k ! Longitude, level indices + integer :: ixq - logical :: labort ! abort flag + logical :: labort ! abort flag - real(r8) tvm(pcols,pver) ! virtual temperature - real(r8) prect(pcols) ! total precipitation real(r8) surfric(pcols) ! surface friction velocity real(r8) obklen(pcols) ! Obukhov length real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry @@ -1516,7 +1486,7 @@ subroutine tphysac (ztodt, cam_in, & ncol = state%ncol nstep = get_nstep() - rtdt = 1._r8/ztodt + call cnst_get_ind('Q', ixq) ! Adjust the surface fluxes to reduce instabilities in near sfc layer if (phys_do_flux_avg()) then @@ -1524,9 +1494,8 @@ subroutine tphysac (ztodt, cam_in, & endif ! Validate the physics state. - if (state_debug_checks) then - call physics_state_check(state, name="before tphysac") - end if + if (state_debug_checks) & + call physics_state_check(state, name="before tphysac") call t_startf('tphysac_init') ! Associate pointers with physics buffer fields @@ -1549,39 +1518,6 @@ subroutine tphysac (ztodt, cam_in, & ifld = pbuf_get_index('AST') call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call cnst_get_ind('Q', ixq) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) - - if (is_subcol_on()) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) - end if - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 - end if - - if (cmfmczm_idx > 0) then - call pbuf_get_field(pbuf, cmfmczm_idx, cmfmczm) - cmfmc(:ncol,:) = cmfmczm(:ncol,:) - else - cmfmc(:ncol,:) = 0._r8 - end if - - call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) - rliq(:ncol) = rliqbc(:ncol) - ! ! accumulate fluxes into net flux array for spectral dycores ! jrm Include latent heat of fusion for snow @@ -1596,12 +1532,12 @@ subroutine tphysac (ztodt, cam_in, & if (trim(cam_take_snapshot_before) == "chem_emissions") then call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + fh2o, surfric, obklen, flx_heat) end if call chem_emissions( state, cam_in, pbuf ) if (trim(cam_take_snapshot_after) == "chem_emissions") then call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + fh2o, surfric, obklen, flx_heat) end if if (carma_do_emission) then @@ -1612,8 +1548,6 @@ subroutine tphysac (ztodt, cam_in, & ! get nstep and zero array for energy checker zero = 0._r8 - zero_sc(:) = 0._r8 - zero_tracers(:,:) = 0._r8 nstep = get_nstep() call check_tracers_init(state, tracerint) @@ -1625,1251 +1559,1343 @@ subroutine tphysac (ztodt, cam_in, & cam_in%shf, cam_in%lhf, cam_in%cflx) call t_stopf('tphysac_init') - !=================================================== - ! Apply tracer surface fluxes to lowest model layer + ! Source/sink terms for advected tracers. !=================================================== - call t_startf('clubb_emissions_tend') - - call clubb_emissions_cam(state, cam_in, ptend) + call t_startf('adv_tracer_src_snk') + ! Test tracers + if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) + if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & + cam_in%cflx) - call check_energy_chng(state, tend, "clubb_emissions_tend", nstep, ztodt, zero, zero, zero, zero) - - call t_stopf('clubb_emissions_tend') + if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + call co2_cycle_set_ptend(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if !=================================================== - ! Calculate tendencies from CARMA bin microphysics. + ! Chemistry and MAM calculation + ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. + ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and + ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before + ! Gas chemistry and MAM core aerosol conversion. + ! Note that surface flux is not added into the atmosphere, but elevated emission is + ! added into the atmosphere as tendency. !=================================================== - ! - ! If CARMA is doing detrainment, then on output, rliq no longer represents - ! water reserved - ! for detrainment, but instead represents potential snow fall. The mass and - ! number of the - ! snow are stored in the physics buffer and will be incorporated by the MG - ! microphysics. - ! - ! Currently CARMA cloud microphysics is only supported with the MG - ! microphysics. - call t_startf('carma_timestep_tend') - - if (carma_do_cldice .or. carma_do_cldliq) then - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & - prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) - call physics_update(state, ptend, ztodt, tend) + if (chem_is_active()) then - ! Before the detrainment, the reserved condensate is all liquid, but if - ! CARMA is doing - ! detrainment, then the reserved condensate is snow. - if (carma_do_detrain) then - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) - else - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) end if - end if - - call t_stopf('carma_timestep_tend') - if( microp_scheme == 'MG' ) then - ! Start co-substepping of macrophysics and microphysics - cld_macmic_ztodt = ztodt/cld_macmic_num_steps + call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & + pbuf, fh2o=fh2o) - ! Clear precip fields that should accumulate. - prec_sed_macmic = 0._r8 - snow_sed_macmic = 0._r8 - prec_pcw_macmic = 0._r8 - snow_pcw_macmic = 0._r8 - ! contrail parameterization - ! see Chen et al., 2012: Global contrail coverage simulated - ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES - ! https://doi.org/10.1029/2011MS000105 - call ssatcontrail_d0(state, pbuf, ztodt, ptend) + if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if call physics_update(state, ptend, ztodt, tend) - ! initialize ptend structures where macro and microphysics tendencies are - ! accumulated over macmic substeps - call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) + if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) + call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & + cam_in%cflx) + end if + call t_stopf('adv_tracer_src_snk') - do macmic_it = 1, cld_macmic_num_steps + !=================================================== + ! Vertical diffusion/pbl calculation + ! Call vertical diffusion code (pbl, free atmosphere and molecular) + !=================================================== - !=================================================== - ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) - !=================================================== + call t_startf('vertical_diffusion_tend') - call t_startf('macrop_tend') + if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - ! ===================================================== - ! CLUBB call (PBL, shallow convection, macrophysics) - ! ===================================================== + call vertical_diffusion_tend (ztodt ,state , cam_in, & + surfric ,obklen ,ptend ,ast ,pbuf ) - if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + !------------------------------------------ + ! Call major diffusion for extended model + !------------------------------------------ + if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then + call waccmx_phys_mspd_tend (ztodt ,state ,ptend) + endif - call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) + if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) + if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + call t_stopf ('vertical_diffusion_tend') - ! Update physics tendencies and copy state to state_eq, because that is - ! input for microphysics - if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_ptend_sum(ptend,ptend_macp_all,ncol) - call physics_update(state, ptend, ztodt, tend) + !=================================================== + ! Rayleigh friction calculation + !=================================================== + call t_startf('rayleigh_friction') + call rayleigh_friction_tend( ztodt, state, ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + call t_stopf('rayleigh_friction') - if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + if (do_clubb_sgs) then + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) + else + call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & + zero, cam_in%shf) + endif - ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code - call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & - cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) + call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) - call t_stopf('macrop_tend') + ! aerosol dry deposition processes + call t_startf('aero_drydep') - !=================================================== - ! Calculate cloud microphysics - !=================================================== + if (trim(cam_take_snapshot_before) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - if (is_subcol_on() .neqv. use_subcol_microp ) then - call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") - end if + call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) + if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - if (is_subcol_on()) then - ! Allocate sub-column structures. - call physics_state_alloc(state_sc, lchnk, psubcols*pcols) - call physics_tend_alloc(tend_sc, psubcols*pcols) + if (trim(cam_take_snapshot_after) == "aero_model_drydep") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - ! Generate sub-columns using the requested scheme - if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) - call subcol_gen(state, tend, state_sc, tend_sc, pbuf) + call t_stopf('aero_drydep') - !Initialize check energy for subcolumns - call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) - end if + ! CARMA microphysics + ! + ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing the dry + ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, so that + ! obklen and surfric have been calculated. It needs to follow aero_model_drydep, so + ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and cam_out + ! can be added to for CARMA aerosols. + if (carma_do_aerosol) then + call t_startf('carma_timestep_tend') + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) + call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_before) == "microp_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('carma_timestep_tend') + end if - call t_startf('microp_aero_run') - call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) - call t_stopf('microp_aero_run') - call t_startf('microp_tend') + !--------------------------------------------------------------------------------- + ! ... enforce charge neutrality + !--------------------------------------------------------------------------------- + call charge_balance(state, pbuf) - if (use_subcol_microp) then + !=================================================== + ! Gravity wave drag + !=================================================== + call t_startf('gw_tend') - if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + if (trim(cam_take_snapshot_before) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) - ! Parameterize subcolumn effects on covariances, if enabled - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) + call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) - ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero - call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) + if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - ! Call the conservative hole filler. - ! Hole filling is only necessary when using subcolumns. - ! Note: this needs to be called after subcol_ptend_avg but before - ! physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & - ptend, pbuf ) + if (trim(cam_take_snapshot_after) == "gw_tend") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - ! Destroy massless droplets - Note this routine returns with no change unless - ! micro_do_massless_droplet_destroyer has been set to true - call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) - ptend ) ! Intent(inout) + ! Check energy integrals + call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & + zero, zero, flx_heat) + call t_stopf('gw_tend') - ! Limit the value of hydrometeor concentrations in order to place - ! reasonable limits on hydrometeor drop size and keep them from - ! becoming too large. - ! Note: this needs to be called after hydrometeor mixing ratio - ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv - ! and after massless drop concentrations are removed by the - ! subcol_SILHS_massless_droplet_destroyer, but before the - ! call to physics_ptend_scale. - if (trim(subcol_scheme) == 'SILHS') & - call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) + ! QBO relaxation - ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend - call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) - call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) - call physics_ptend_dealloc(ptend_aero_sc) + if (trim(cam_take_snapshot_before) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) + call qbo_relax(state, pbuf, ptend) + if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state_sc, ptend_sc, ztodt, tend_sc) + if (trim(cam_take_snapshot_after) == "qbo_relax") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + ! Check energy integrals + call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) - call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & - nstep, ztodt, zero_sc, & - prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & - snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) + ! Lunar tides + call lunar_tides_tend( state, ptend ) + if ( ptend%lu ) then + call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) + ! Check energy integrals + call check_energy_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) - call physics_state_dealloc(state_sc) - call physics_tend_dealloc(tend_sc) - call physics_ptend_dealloc(ptend_sc) - else - call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) - end if - ! combine aero and micro tendencies for the grid - call physics_ptend_sum(ptend_aero, ptend, ncol) - call physics_ptend_dealloc(ptend_aero) + ! Ion drag calculation + call t_startf ( 'iondrag' ) - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) + if ( do_waccm_ions ) then + call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + else + call iondrag_calc( lchnk, ncol, state, ptend) + endif + !---------------------------------------------------------------------------- + ! Call ionosphere routines for extended model if mode is set to ionosphere + !---------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) + endif - if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update (state, ptend, ztodt, tend) + if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + if ( ptend%lu ) then + call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) + end if + call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "microp_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if - call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & - zero, prec_str(:ncol)/cld_macmic_num_steps, & - snow_str(:ncol)/cld_macmic_num_steps, zero) + call tot_energy_phys(state, 'phAP') + call tot_energy_phys(state, 'dyAP',vc=vc_dycore) - call t_stopf('microp_tend') + !--------------------------------------------------------------------------------- + ! Enforce charge neutrality after O+ change from ionos_tend + !--------------------------------------------------------------------------------- + if( waccmx_is('ionosphere') ) then + call charge_balance(state, pbuf) + endif - prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) - snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) - prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) - snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) + ! Check energy integrals + call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) - end do ! end substepping over macrophysics/microphysics + call t_stopf ( 'iondrag' ) - call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) - call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) - call physics_ptend_dealloc(ptend_macp_all) + ! Update Nudging values, if needed + !---------------------------------- + if((Nudge_Model).and.(Nudge_ON)) then + call nudging_timestep_tend(state,ptend) + if ( ptend%lu ) then + call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) + end if + if ( ptend%lv ) then + call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) + end if + call physics_update(state,ptend,ztodt,tend) + call check_energy_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) + endif + + !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + + ! Save total energy for global fixer in next timestep + ! + ! This call must be after the last parameterization and call to physics_update + ! + call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) + + if (shallow_scheme .eq. 'UNICON') then + + ! ------------------------------------------------------------------------ + ! Insert the organization-related heterogeneities computed inside the + ! UNICON into the tracer arrays here before performing advection. + ! This is necessary to prevent any modifications of organization-related + ! heterogeneities by non convection-advection process, such as + ! dry and wet deposition of aerosols, MAM, etc. + ! Again, note that only UNICON and advection schemes are allowed to + ! changes to organization at this stage, although we can include the + ! effects of other physical processes in future. + ! ------------------------------------------------------------------------ + + call unicon_cam_org_diags(state, pbuf) + + end if + ! + ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust + ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. + moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') + ! + ! update cp/cv for energy computation based in updated water variables + ! + call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& + to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + + ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. + ! So, save off tracers + if (.not.moist_mixing_ratio_dycore) then + ! + ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core + ! + ! only compute dme_adjust for diagnostics purposes + ! + if (thermo_budget_history) then + tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) + tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) + tmp_ps(:ncol) = state%ps(:ncol) + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + ! Restore pre-"physics_dme_adjust" tracers + state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) + state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) + state%ps(:ncol) = tmp_ps(:ncol) + end if + else + ! + ! for moist-mixing ratio based dycores + ! + ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call + ! + call set_dry_to_wet(state) + + if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) + if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then + call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& + fh2o, surfric, obklen, flx_heat) + end if + + call tot_energy_phys(state, 'phAM') + call tot_energy_phys(state, 'dyAM', vc=vc_dycore) + endif + + if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then + ! + ! MPAS and SE specific scaling of temperature for enforcing energy consistency + ! (and to make sure that temperature dependent diagnostic tendencies + ! are computed correctly; e.g. dtcore) + ! + scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) + state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& + scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) + tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) + ! + ! else: do nothing for dycores with energy consistent with CAM physics + ! + end if + + + ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep + do k = 1,pver + dtcore(:ncol,k) = state%t(:ncol,k) + dqcore(:ncol,k) = state%q(:ncol,k,ixq) + ducore(:ncol,k) = state%u(:ncol,k) + dvcore(:ncol,k) = state%v(:ncol,k) + end do - prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps - snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps - prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps - snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps - prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) - snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) + !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + if (aqua_planet) then + labort = .false. + do i=1,ncol + if (cam_in%ocnfrac(i) /= 1._r8) then + labort = .true. + if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) + end if + end do + if (labort) then + call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') + endif endif - ! Add the precipitation from CARMA to the precipitation from stratiform. - if (carma_do_cldice .or. carma_do_cldliq) then - prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) - snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) - end if - - if ( .not. deep_scheme_does_scav_trans() ) then + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) - ! ------------------------------------------------------------------------------- - ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. - ! 2. Convective Transport of Non-Water Aerosol Species. - ! - ! . Aerosol wet chemistry determines scavenging fractions, and transformations - ! . Then do convective transport of all trace species except qv,ql,qi. - ! . We needed to do the scavenging first to determine the interstitial fraction. - ! . When UNICON is used as unified convection, we should still perform - ! wet scavenging but not 'convect_deep_tend2'. - ! ------------------------------------------------------------------------------- + call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) - call t_startf('bc_aerosols') - if (clim_modal_aero .and. .not. prog_modal_aero) then - call modal_aero_calcsize_diag(state, pbuf) - call modal_aero_wateruptake_dr(state, pbuf) - endif + end subroutine tphysac - if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + subroutine tphysbc (ztodt, state, & + tend, pbuf, & + cam_out, cam_in ) + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Evaluate and apply physical processes that are calculated BEFORE + ! coupling to land, sea, and ice models. + ! + ! Processes currently included are: + ! + ! o Resetting Negative Tracers to Positive + ! o Global Mean Total Energy Fixer + ! o Dry Adjustment + ! o Asymmetric Turbulence Scheme : Deep Convection & Shallow Convection + ! o Stratiform Macro-Microphysics + ! o Wet Scavenging of Aerosol + ! o Radiation + ! + ! Method: + ! + ! Each parameterization should be implemented with this sequence of calls: + ! 1) Call physics interface + ! 2) Check energy + ! 3) Call physics_update + ! See Interface to Column Physics and Chemistry Packages + ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html + ! + !----------------------------------------------------------------------- - call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) - if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + use physics_buffer, only: physics_buffer_desc, pbuf_get_field + use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx + use physics_buffer, only: col_type_subcol, dyn_time_lvls + use shr_kind_mod, only: r8 => shr_kind_r8 - if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + use dadadj_cam, only: dadadj_tend + use rk_stratiform, only: rk_stratiform_tend + use microp_driver, only: microp_driver_tend + use microp_aero, only: microp_aero_run + use macrop_driver, only: macrop_driver_tend + use physics_types, only: physics_state, physics_tend, physics_ptend, & + physics_update, physics_ptend_init, physics_ptend_sum, & + physics_state_check, physics_ptend_scale, & + dyn_te_idx + use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write + use cam_diagnostics, only: diag_clip_tend_writeout + use cam_history, only: outfld + use physconst, only: latvap + use constituents, only: pcnst, qmin, cnst_get_ind + use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx + use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx + use convect_deep, only: convect_deep_tend, convect_deep_tend_2, deep_scheme_does_scav_trans + use time_manager, only: is_first_step, get_nstep + use convect_shallow, only: convect_shallow_tend + use check_energy, only: check_energy_chng, check_energy_fix, check_energy_timestep_init + use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng + use check_energy, only: tot_energy_phys + use dycore, only: dycore_is + use aero_model, only: aero_model_wetdep + use carma_intr, only: carma_wetdep_tend, carma_timestep_tend + use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep + use radiation, only: radiation_tend + use cloud_diagnostics, only: cloud_diagnostics_calc + use perf_mod + use mo_gas_phase_chemdr,only: map2chm + use clybry_fam, only: clybry_fam_adj + use clubb_intr, only: clubb_tend_cam + use sslt_rebin, only: sslt_rebin_adv + use tropopause, only: tropopause_output + use cam_abortutils, only: endrun + use subcol, only: subcol_gen, subcol_ptend_avg + use subcol_utils, only: subcol_ptend_copy, is_subcol_on + use qneg_module, only: qneg3 + use subcol_SILHS, only: subcol_SILHS_var_covar_driver, init_state_subcol + use subcol_SILHS, only: subcol_SILHS_fill_holes_conserv + use subcol_SILHS, only: subcol_SILHS_hydromet_conc_tend_lim + use micro_pumas_cam, only: massless_droplet_destroyer + use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc + use cam_snapshot_common, only: cam_snapshot_ptend_outfld + use ssatcontrail, only: ssatcontrail_d0 + use dyn_tests_utils, only: vc_dycore - if (carma_do_wetdep) then - ! CARMA wet deposition - ! - ! NOTE: It needs to follow aero_model_wetdep, so that - ! cam_out%xxxwetxxx - ! fields have already been set for CAM aerosols and cam_out can be - ! added - ! to for CARMA aerosols. - call t_startf ('carma_wetdep_tend') - call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('carma_wetdep_tend') - end if + ! Arguments - call t_startf ('convect_deep_tend2') - call convect_deep_tend_2( state, ptend, ztodt, pbuf ) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('convect_deep_tend2') + real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - ! check tracer integrals - call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) + type(physics_state), intent(inout) :: state + type(physics_tend ), intent(inout) :: tend + type(physics_buffer_desc), pointer :: pbuf(:) - call t_stopf('bc_aerosols') + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in - endif - !=================================================== - ! Moist physical parameteriztions complete: - ! send dynamical variables, and derived variables to history file - !=================================================== + ! + !---------------------------Local workspace----------------------------- + ! - call t_startf('bc_history_write') - call diag_phys_writeout(state, pbuf) - call diag_conv(state, ztodt, pbuf) + type(physics_ptend) :: ptend ! indivdual parameterization tendencies + type(physics_ptend) :: ptend_macp_all ! sum of macrophysics tendencies (e.g. CLUBB) over substeps + type(physics_state) :: state_sc ! state for sub-columns + type(physics_ptend) :: ptend_sc ! ptend for sub-columns + type(physics_ptend) :: ptend_aero ! ptend for microp_aero + type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns + type(physics_tend) :: tend_sc ! tend for sub-columns - call t_stopf('bc_history_write') + integer :: nstep ! current timestep number - !=================================================== - ! Write cloud diagnostics on history file - !=================================================== + real(r8) :: net_flx(pcols) - call t_startf('bc_cld_diag_history_write') + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - call cloud_diagnostics_calc(state, pbuf) + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - call t_stopf('bc_cld_diag_history_write') + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev + real(r8) rtdt ! 1./ztodt - !=================================================== - ! Radiation computations - !=================================================== - call t_startf('radiation') + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns - if (trim(cam_take_snapshot_before) == "radiation_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + integer :: m, m_cnst + ! for macro/micro co-substepping + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep + ! physics buffer fields to compute tendencies for stratiform package + integer itim_old, ifld + real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) - ! Set net flux used by spectral dycores - do i=1,ncol - tend%flx_net(i) = net_flx(i) - end do + ! physics buffer fields for total energy and mass adjustment + real(r8), pointer, dimension(: ) :: teout + real(r8), pointer, dimension(:,:) :: qini + real(r8), pointer, dimension(:,:) :: cldliqini + real(r8), pointer, dimension(:,:) :: cldiceini + real(r8), pointer, dimension(:,:) :: totliqini + real(r8), pointer, dimension(:,:) :: toticeini + real(r8), pointer, dimension(:,:) :: dtcore + real(r8), pointer, dimension(:,:) :: dqcore + real(r8), pointer, dimension(:,:) :: ducore + real(r8), pointer, dimension(:,:) :: dvcore - if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - if (trim(cam_take_snapshot_after) == "radiation_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) + ! convective precipitation variables + real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection + real(r8),pointer :: snow_dp(:) ! snow from ZM convection + real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection + real(r8),pointer :: snow_sh(:) ! snow from Hack convection - call t_stopf('radiation') + ! carma precipitation variables + real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) + real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) - ! Diagnose the location of the tropopause and its location to the history file(s). - call t_startf('tropopause') - call tropopause_output(state) - call t_stopf('tropopause') + ! stratiform precipitation variables + real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) + real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) + real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns + real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns + real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme + real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme + real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation + real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - !=================================================== - ! Source/sink terms for advected tracers. - !=================================================== - call t_startf('adv_tracer_src_snk') - ! Test tracers + ! Local copies for substepping + real(r8) :: prec_pcw_macmic(pcols) + real(r8) :: snow_pcw_macmic(pcols) + real(r8) :: prec_sed_macmic(pcols) + real(r8) :: snow_sed_macmic(pcols) - if (trim(cam_take_snapshot_before) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) - if ( (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "aoa_tracers_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & - cam_in%cflx) + ! energy checking variables + real(r8) :: zero(pcols) ! array of zeros + real(r8) :: zero_sc(pcols*psubcols) ! array of zeros + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: flx_cnd(pcols) + real(r8) :: flx_heat(pcols) + type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes + real(r8) :: zero_tracers(pcols,pcnst) - if (trim(cam_take_snapshot_before) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call co2_cycle_set_ptend(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "co2_cycle_set_ptend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + !----------------------------------------------------------------------- - !=================================================== - ! Chemistry and MAM calculation - ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. - ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and - ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before - ! Gas chemistry and MAM core aerosol conversion. - ! Note that surface flux is not added into the atmosphere, but elevated emission is - ! added into the atmosphere as tendency. - !=================================================== - if (chem_is_active()) then + call t_startf('bc_init') - if (trim(cam_take_snapshot_before) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + zero = 0._r8 + zero_tracers(:,:) = 0._r8 + zero_sc(:) = 0._r8 - call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & - pbuf, fh2o=fh2o) + lchnk = state%lchnk + ncol = state%ncol + rtdt = 1._r8/ztodt - if ( (trim(cam_take_snapshot_after) == "chem_timestep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + nstep = get_nstep() - if (trim(cam_take_snapshot_after) == "chem_timestep_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) - call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & - cam_in%cflx) - end if - call t_stopf('adv_tracer_src_snk') + ! Associate pointers with physics buffer fields + itim_old = pbuf_old_tim_idx() + ifld = pbuf_get_index('CLD') + call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) - !=================================================== - ! Vertical diffusion/pbl calculation - ! Call vertical diffusion (apply tracer emissions, molecular diffusion and pbl form drag) - !=================================================== + call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) - call t_startf('vertical_diffusion_tend') + call pbuf_get_field(pbuf, qini_idx, qini) + call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) + call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) + call pbuf_get_field(pbuf, totliqini_idx, totliqini) + call pbuf_get_field(pbuf, toticeini_idx, toticeini) - if (trim(cam_take_snapshot_before) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call vertical_diffusion_tend (ztodt ,state , cam_in, & - surfric ,obklen ,ptend ,ast ,pbuf ) + ifld = pbuf_get_index('FRACIS') + call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + fracis (:ncol,:,1:pcnst) = 1._r8 - !------------------------------------------ - ! Call major diffusion for extended model - !------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_tend (ztodt ,state ,ptend) - endif + ! Set physics tendencies to 0 + tend %dTdt(:ncol,:pver) = 0._r8 + tend %dudt(:ncol,:pver) = 0._r8 + tend %dvdt(:ncol,:pver) = 0._r8 - if ( (trim(cam_take_snapshot_after) == "vertical_diffusion_section") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_VDIFF', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_VDIFF', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + ! Verify state coming from the dynamics + if (state_debug_checks) & + call physics_state_check(state, name="before tphysbc (dycore?)") - if (trim(cam_take_snapshot_after) == "vertical_diffusion_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) - call t_stopf ('vertical_diffusion_tend') + ! Since clybry_fam_adj operates directly on the tracers, and has no + ! physics_update call, re-run qneg3. + call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & + 1, pcnst, qmin ,state%q ) - !=================================================== - ! Rayleigh friction calculation - !=================================================== - call t_startf('rayleigh_friction') - call rayleigh_friction_tend( ztodt, state, ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_RAYLEIGH', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_RAYLEIGH', ptend%v, pcols, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) - call t_stopf('rayleigh_friction') + ! Validate output of clybry_fam_adj. + if (state_debug_checks) & + call physics_state_check(state, name="clybry_fam_adj") - if (do_clubb_sgs) then - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) - else - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & - zero, cam_in%shf) - endif + ! + ! Dump out "before physics" state + ! + call diag_state_b4_phys_write (state) - call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) + ! compute mass integrals of input tracers state + call check_tracers_init(state, tracerint) - ! aerosol dry deposition processes - call t_startf('aero_drydep') + call t_stopf('bc_init') - if (trim(cam_take_snapshot_before) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + !=================================================== + ! Global mean total energy fixer + !=================================================== + call t_startf('energy_fixer') - call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) - if ( (trim(cam_take_snapshot_after) == "aero_model_drydep") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call tot_energy_phys(state, 'phBF') + call tot_energy_phys(state, 'dyBF',vc=vc_dycore) + if (.not.dycore_is('EUL')) then + call check_energy_fix(state, ptend, nstep, flx_heat) + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) + call outfld( 'EFIX', flx_heat , pcols, lchnk ) end if - call physics_update(state, ptend, ztodt, tend) + call tot_energy_phys(state, 'phBP') + call tot_energy_phys(state, 'dyBP',vc=vc_dycore) + ! Save state for convective tendency calculations. + call diag_conv_tend_ini(state, pbuf) - if (trim(cam_take_snapshot_after) == "aero_model_drydep") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + call cnst_get_ind('Q', ixq) + call cnst_get_ind('CLDLIQ', ixcldliq) + call cnst_get_ind('CLDICE', ixcldice) + qini (:ncol,:pver) = state%q(:ncol,:pver, 1) + cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - call t_stopf('aero_drydep') + totliqini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_liq_num + m = thermodynamic_active_species_liq_idx(m_cnst) + totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do + toticeini(:ncol,:pver) = 0.0_r8 + do m_cnst=1,thermodynamic_active_species_ice_num + m = thermodynamic_active_species_ice_idx(m_cnst) + toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) + end do - ! CARMA microphysics - ! - ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing - ! the dry - ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, - ! so that - ! obklen and surfric have been calculated. It needs to follow - ! aero_model_drydep, so - ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and - ! cam_out - ! can be added to for CARMA aerosols. - if (carma_do_aerosol) then - call t_startf('carma_timestep_tend') - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) - call t_stopf('carma_timestep_tend') - end if + call outfld('TEOUT', teout , pcols, lchnk ) + call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) + call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) - !--------------------------------------------------------------------------------- - ! ... enforce charge neutrality - !--------------------------------------------------------------------------------- - call charge_balance(state, pbuf) + ! T, U, V tendency due to dynamics + if( nstep > dyn_time_lvls-1 ) then + dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt + dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt + ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt + dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt + call outfld( 'DTCORE', dtcore, pcols, lchnk ) + call outfld( 'DQCORE', dqcore, pcols, lchnk ) + call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) + call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) + end if + call t_stopf('energy_fixer') + ! !=================================================== - ! Gravity wave drag + ! Dry adjustment !=================================================== - call t_startf('gw_tend') + call t_startf('dry_adjustment') - if (trim(cam_take_snapshot_before) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_before) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) + call dadadj_tend(ztodt, state, ptend) - if ( (trim(cam_take_snapshot_after) == "gw_tend") .and. & + if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - if ( ptend%lu ) then - call outfld( 'UTEND_GWDTOT', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_GWDTOT', ptend%v, pcols, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "gw_tend") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "dadadj_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - ! Check energy integrals - call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & - zero, zero, flx_heat) - call t_stopf('gw_tend') + call t_stopf('dry_adjustment') - ! QBO relaxation + !=================================================== + ! Moist convection + !=================================================== + call t_startf('moist_convection') - if (trim(cam_take_snapshot_before) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + call t_startf ('convect_deep_tend') + + if (trim(cam_take_snapshot_before) == "convect_deep_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - call qbo_relax(state, pbuf, ptend) - if ( (trim(cam_take_snapshot_after) == "qbo_relax") .and. & + call convect_deep_tend( & + cmfmc, cmfcme, & + pflx, zdu, & + rliq, rice, & + ztodt, & + state, ptend, cam_in%landfrac, pbuf) + + if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) end if + if ( ptend%lu ) then - call outfld( 'UTEND_QBORLX', ptend%u, pcols, lchnk) + call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) end if if ( ptend%lv ) then - call outfld( 'VTEND_QBORLX', ptend%v, pcols, lchnk) + call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "qbo_relax") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "convect_deep_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - ! Check energy integrals - call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) + call t_stopf('convect_deep_tend') - ! Lunar tides - call lunar_tides_tend( state, ptend ) - if ( ptend%lu ) then - call outfld( 'UTEND_LUNART', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_LUNART', ptend%v, pcols, lchnk) + call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) + call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) + call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) + call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) + call pbuf_get_field(pbuf, prec_str_idx, prec_str ) + call pbuf_get_field(pbuf, snow_str_idx, snow_str ) + call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) + call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) + call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) + call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) + + if (use_subcol_microp) then + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) end if - call physics_update(state, ptend, ztodt, tend) - ! Check energy integrals - call check_energy_chng(state, tend, "lunar_tides", nstep, ztodt, zero, zero, zero, zero) - ! Ion drag calculation - call t_startf ( 'iondrag' ) + ! Check energy integrals, including "reserved liquid" + flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) + snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) + call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) + snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) - if (trim(cam_take_snapshot_before) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + ! + ! Call Hack (1994) convection scheme to deal with shallow/mid-level convection + ! + call t_startf ('convect_shallow_tend') - if ( do_waccm_ions ) then - call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) + if (dlfzm_idx > 0) then + call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) + dlf(:ncol,:) = dlfzm(:ncol,:) else - call iondrag_calc( lchnk, ncol, state, ptend) - endif - !---------------------------------------------------------------------------- - ! Call ionosphere routines for extended model if mode is set to ionosphere - !---------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) - endif + dlf(:,:) = 0._r8 + end if - if ( (trim(cam_take_snapshot_after) == "iondrag_calc_section") .and. & + if (trim(cam_take_snapshot_before) == "convect_shallow_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if + + call convect_shallow_tend (ztodt , cmfmc, & + dlf , dlf2 , rliq , rliq2, & + state , ptend , pbuf, cam_in) + call t_stopf ('convect_shallow_tend') + + if ( (trim(cam_take_snapshot_after) == "convect_shallow_tend") .and. & (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) + call cam_snapshot_ptend_outfld(ptend, lchnk) end if if ( ptend%lu ) then - call outfld( 'UTEND_IONDRG', ptend%u, pcols, lchnk) + call outfld( 'UTEND_SHCONV', ptend%u, pcols, lchnk) end if if ( ptend%lv ) then - call outfld( 'VTEND_IONDRG', ptend%v, pcols, lchnk) + call outfld( 'VTEND_SHCONV', ptend%v, pcols, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "iondrag_calc_section") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) + if (trim(cam_take_snapshot_after) == "convect_shallow_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - call tot_energy_phys(state, 'phAP') - call tot_energy_phys(state, 'dyAP',vc=vc_dycore) - !--------------------------------------------------------------------------------- - ! Enforce charge neutrality after O+ change from ionos_tend - !--------------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call charge_balance(state, pbuf) - endif + flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) + call check_energy_chng(state, tend, "convect_shallow", nstep, ztodt, zero, flx_cnd, snow_sh, zero) - ! Check energy integrals - call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) + call check_tracers_chng(state, tracerint, "convect_shallow", nstep, ztodt, zero_tracers) - call t_stopf ( 'iondrag' ) + call t_stopf('moist_convection') - ! Update Nudging values, if needed - !---------------------------------- - if((Nudge_Model).and.(Nudge_ON)) then - call nudging_timestep_tend(state,ptend) - if ( ptend%lu ) then - call outfld( 'UTEND_NDG', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_NDG', ptend%v, pcols, lchnk) - end if - call physics_update(state,ptend,ztodt,tend) - call check_energy_chng(state, tend, "nudging", nstep, ztodt, zero, zero, zero, zero) - endif + ! Rebin the 4-bin version of sea salt into bins for coarse and accumulation + ! modes that correspond to the available optics data. This is only necessary + ! for CAM-RT. But it's done here so that the microphysics code which is called + ! from the stratiform interface has access to the same aerosols as the radiation + ! code. + call sslt_rebin_adv(pbuf, state) - !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - ! Save total energy for global fixer in next timestep - ! - ! This call must be after the last parameterization and call to physics_update - ! - call pbuf_set_field(pbuf, teout_idx, state%te_cur(:,dyn_te_idx), (/1,itim_old/),(/pcols,1/)) - ! - ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust - ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. - moist_mixing_ratio_dycore = dycore_is('LR').or. dycore_is('FV3') + !=================================================== + ! Calculate tendencies from CARMA bin microphysics. + !=================================================== ! - ! update cp/cv for energy computation based in updated water variables + ! If CARMA is doing detrainment, then on output, rliq no longer represents water reserved + ! for detrainment, but instead represents potential snow fall. The mass and number of the + ! snow are stored in the physics buffer and will be incorporated by the MG microphysics. ! - call cam_thermo_water_update(state%q(:ncol,:,:), lchnk, ncol, vc_dycore,& - to_dry_factor=state%pdel(:ncol,:)/state%pdeldry(:ncol,:)) + ! Currently CARMA cloud microphysics is only supported with the MG microphysics. + call t_startf('carma_timestep_tend') - ! for dry mixing ratio dycore, physics_dme_adjust is called for energy diagnostic purposes only. - ! So, save off tracers - if (.not.moist_mixing_ratio_dycore) then - ! - ! for dry-mixing ratio based dycores dme_adjust takes place in the dynamical core - ! - ! only compute dme_adjust for diagnostics purposes - ! - if (thermo_budget_history) then - tmp_trac(:ncol,:pver,:pcnst) = state%q(:ncol,:pver,:pcnst) - tmp_pdel(:ncol,:pver) = state%pdel(:ncol,:pver) - tmp_ps(:ncol) = state%ps(:ncol) - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - ! Restore pre-"physics_dme_adjust" tracers - state%q(:ncol,:pver,:pcnst) = tmp_trac(:ncol,:pver,:pcnst) - state%pdel(:ncol,:pver) = tmp_pdel(:ncol,:pver) - state%ps(:ncol) = tmp_ps(:ncol) - end if - else - ! - ! for moist-mixing ratio based dycores - ! - ! Note: this operation will NOT be reverted with set_wet_to_dry after set_dry_to_wet call - ! - call set_dry_to_wet(state) + if (carma_do_cldice .or. carma_do_cldliq) then + call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & + prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) + call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_before) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if - call physics_dme_adjust(state, tend, qini, totliqini, toticeini, ztodt) - if (trim(cam_take_snapshot_after) == "physics_dme_adjust") then - call cam_snapshot_all_outfld_tphysac(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf,& - fh2o, surfric, obklen, flx_heat, cmfmc, dlf, det_s, det_ice, net_flx) - end if + ! Before the detrainment, the reserved condensate is all liquid, but if CARMA is doing + ! detrainment, then the reserved condensate is snow. + if (carma_do_detrain) then + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) + else + call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) + end if + end if - call tot_energy_phys(state, 'phAM') - call tot_energy_phys(state, 'dyAM', vc=vc_dycore) - endif + call t_stopf('carma_timestep_tend') - if (vc_dycore == vc_height.or.vc_dycore == vc_dry_pressure) then - ! - ! MPAS and SE specific scaling of temperature for enforcing energy consistency - ! (and to make sure that temperature dependent diagnostic tendencies - ! are computed correctly; e.g. dtcore) - ! - scaling(1:ncol,:) = cpairv(:ncol,:,lchnk)/cp_or_cv_dycore(:ncol,:,lchnk) - state%T(1:ncol,:) = state%temp_ini(1:ncol,:)+& - scaling(1:ncol,:)*(state%T(1:ncol,:)-state%temp_ini(1:ncol,:)) - tend%dtdt(:ncol,:) = scaling(:ncol,:)*tend%dtdt(:ncol,:) - ! - ! else: do nothing for dycores with energy consistent with CAM physics - ! - end if + if( microp_scheme == 'RK' ) then + !=================================================== + ! Calculate stratiform tendency (sedimentation, detrain, cloud fraction and microphysics ) + !=================================================== + call t_startf('rk_stratiform_tend') - ! store T, U, and V in buffer for use in computing dynamics T-tendency in next timestep - do k = 1,pver - dtcore(:ncol,k) = state%t(:ncol,k) - dqcore(:ncol,k) = state%q(:ncol,k,ixq) - ducore(:ncol,k) = state%u(:ncol,k) - dvcore(:ncol,k) = state%v(:ncol,k) - end do + call rk_stratiform_tend(state, ptend, pbuf, ztodt, & + cam_in%icefrac, cam_in%landfrac, cam_in%ocnfrac, & + cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + rliq , & ! check energy after detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu) - !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + call physics_update(state, ptend, ztodt, tend) + call check_energy_chng(state, tend, "cldwat_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - if (aqua_planet) then - labort = .false. - do i=1,ncol - if (cam_in%ocnfrac(i) /= 1._r8) then - labort = .true. - if (masterproc) write(iulog,*) 'oceanfrac(',i,')=',cam_in%ocnfrac(i) - end if - end do - if (labort) then - call endrun ('TPHYSAC error: in aquaplanet mode, but grid contains non-ocean point') - endif - endif + call t_stopf('rk_stratiform_tend') + + elseif( microp_scheme == 'MG' ) then + ! Start co-substepping of macrophysics and microphysics + cld_macmic_ztodt = ztodt/cld_macmic_num_steps + + ! Clear precip fields that should accumulate. + prec_sed_macmic = 0._r8 + snow_sed_macmic = 0._r8 + prec_pcw_macmic = 0._r8 + snow_pcw_macmic = 0._r8 + + ! contrail parameterization + ! see Chen et al., 2012: Global contrail coverage simulated + ! by CAM5 with the inventory of 2006 global aircraft emissions, JAMES + ! https://doi.org/10.1029/2011MS000105 + call ssatcontrail_d0(state, pbuf, ztodt, ptend) + call physics_update(state, ptend, ztodt, tend) + + ! initialize ptend structures where macro and microphysics tendencies are + ! accumulated over macmic substeps + call physics_ptend_init(ptend_macp_all,state%psetcols,'macrophysics',lu=.true.,lv=.true.) + + do macmic_it = 1, cld_macmic_num_steps + + !=================================================== + ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) + !=================================================== + + call t_startf('macrop_tend') + + ! don't call Park macrophysics if CLUBB is called + if (macrop_scheme .ne. 'CLUBB_SGS') then + + if (trim(cam_take_snapshot_before) == "macrop_driver_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if + + call macrop_driver_tend( & + state, ptend, cld_macmic_ztodt, & + cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment + dlf, dlf2, & ! detrain + cmfmc, & + cam_in%ts, cam_in%sst, zdu, & + pbuf, det_s, det_ice) + + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = det_s(:ncol) + + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) + if ( (trim(cam_take_snapshot_after) == "macrop_driver_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_ptend_sum(ptend,ptend_macp_all,ncol) + call physics_update(state, ptend, ztodt, tend) + + if (trim(cam_take_snapshot_after) == "macrop_driver_tend") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, qini, cldliqini, cldiceini) + call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & + zero, flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) - call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) + else ! Calculate CLUBB macrophysics - end subroutine tphysac + ! ===================================================== + ! CLUBB call (PBL, shallow convection, macrophysics) + ! ===================================================== - subroutine tphysbc (ztodt, state, & - tend, pbuf, & - cam_out, cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Evaluate and apply physical processes that are calculated BEFORE - ! coupling to land, sea, and ice models. - ! - ! Processes currently included are: - ! - ! o Resetting Negative Tracers to Positive - ! o Global Mean Total Energy Fixer - ! o Dry Adjustment - ! o Asymmetric Turbulence Scheme - Deep Convection & Shallow Convection - ! - ! Method: - ! - ! Each parameterization should be implemented with this sequence of calls: - ! 1) Call physics interface - ! 2) Check energy - ! 3) Call physics_update - ! See Interface to Column Physics and Chemistry Packages - ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html - ! - !----------------------------------------------------------------------- + if (trim(cam_take_snapshot_before) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx - use physics_buffer, only: col_type_subcol, dyn_time_lvls + call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) - use dadadj_cam, only: dadadj_tend - use physics_types, only: physics_update, & - physics_state_check, & - dyn_te_idx - use cam_diagnostics, only: diag_conv_tend_ini, diag_conv, diag_export, diag_state_b4_phys_write - use cam_history, only: outfld - use constituents, only: qmin - use air_composition, only: thermodynamic_active_species_liq_num,thermodynamic_active_species_liq_idx - use air_composition, only: thermodynamic_active_species_ice_num,thermodynamic_active_species_ice_idx - use convect_deep, only: convect_deep_tend - use time_manager, only: is_first_step, get_nstep - use convect_diagnostics,only: convect_diagnostics_calc - use check_energy, only: check_energy_chng, check_energy_fix - use check_energy, only: check_tracers_data, check_tracers_init - use check_energy, only: tot_energy_phys - use dycore, only: dycore_is - use radiation, only: radiation_tend - use perf_mod - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_adj - use cam_abortutils, only: endrun - use subcol_utils, only: is_subcol_on - use qneg_module, only: qneg3 - use cam_snapshot, only: cam_snapshot_all_outfld_tphysbc - use cam_snapshot_common, only: cam_snapshot_ptend_outfld - use dyn_tests_utils, only: vc_dycore + ! Since we "added" the reserved liquid back in this routine, we need + ! to account for it in the energy checker + flx_cnd(:ncol) = -1._r8*rliq(:ncol) + flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - ! Arguments + ! Unfortunately, physics_update does not know what time period + ! "tend" is supposed to cover, and therefore can't update it + ! with substeps correctly. For now, work around this by scaling + ! ptend down by the number of substeps, then applying it for + ! the full time (ztodt). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) + ! Update physics tendencies and copy state to state_eq, because that is + ! input for microphysics + if ( (trim(cam_take_snapshot_after) == "clubb_tend_cam") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_ptend_sum(ptend,ptend_macp_all,ncol) + call physics_update(state, ptend, ztodt, tend) - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) + if (trim(cam_take_snapshot_after) == "clubb_tend_cam") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in + ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code + call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) + endif - ! - !---------------------------Local workspace----------------------------- - ! + call t_stopf('macrop_tend') - type(physics_ptend) :: ptend ! indivdual parameterization tendencies + !=================================================== + ! Calculate cloud microphysics + !=================================================== - integer :: nstep ! current timestep number + if (is_subcol_on() .neqv. use_subcol_microp ) then + call endrun("Error calculating cloud microphysics: is_subcol_on() != use_subcol_microp") + end if - real(r8) :: net_flx(pcols) + if (is_subcol_on()) then + ! Allocate sub-column structures. + call physics_state_alloc(state_sc, lchnk, psubcols*pcols) + call physics_tend_alloc(tend_sc, psubcols*pcols) - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + ! Generate sub-columns using the requested scheme + if (trim(subcol_scheme) == 'SILHS') call init_state_subcol(state, tend, state_sc, tend_sc) + call subcol_gen(state, tend, state_sc, tend_sc, pbuf) - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + !Initialize check energy for subcolumns + call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) + end if - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev - real(r8) rtdt ! 1./ztodt + if (trim(cam_take_snapshot_before) == "microp_section") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns + call t_startf('microp_aero_run') + call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('microp_aero_run') - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. - integer :: m, m_cnst + call t_startf('microp_tend') - ! physics buffer fields to compute tendencies for stratiform package - integer itim_old, ifld - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction + if (use_subcol_microp) then - ! physics buffer fields for total energy and mass adjustment - real(r8), pointer, dimension(: ) :: teout - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: totliqini - real(r8), pointer, dimension(:,:) :: toticeini - real(r8), pointer, dimension(:,:) :: dtcore - real(r8), pointer, dimension(:,:) :: dqcore - real(r8), pointer, dimension(:,:) :: ducore - real(r8), pointer, dimension(:,:) :: dvcore + if (trim(cam_take_snapshot_before) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble + call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) + ! Parameterize subcolumn effects on covariances, if enabled + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_var_covar_driver( cld_macmic_ztodt, state_sc, ptend_sc, pbuf ) - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - real(r8), pointer :: rliqbc(:) ! tphysbc reserve liquid + ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero + call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - ! convective precipitation variables - real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8),pointer :: snow_dp(:) ! snow from ZM convection - real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8),pointer :: snow_sh(:) ! snow from Hack convection + ! Call the conservative hole filler. + ! Hole filling is only necessary when using subcolumns. + ! Note: this needs to be called after subcol_ptend_avg but before + ! physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_fill_holes_conserv( state, cld_macmic_ztodt, & + ptend, pbuf ) - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation + ! Destroy massless droplets - Note this routine returns with no change unless + ! micro_do_massless_droplet_destroyer has been set to true + call massless_droplet_destroyer( cld_macmic_ztodt, state, & ! Intent(in) + ptend ) ! Intent(inout) - ! energy checking variables - real(r8) :: zero(pcols) ! array of zeros - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) - type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes - real(r8) :: zero_tracers(pcols,pcnst) + ! Limit the value of hydrometeor concentrations in order to place + ! reasonable limits on hydrometeor drop size and keep them from + ! becoming too large. + ! Note: this needs to be called after hydrometeor mixing ratio + ! tendencies are adjusted by subcol_SILHS_fill_holes_conserv + ! and after massless drop concentrations are removed by the + ! subcol_SILHS_massless_droplet_destroyer, but before the + ! call to physics_ptend_scale. + if (trim(subcol_scheme) == 'SILHS') & + call subcol_SILHS_hydromet_conc_tend_lim( state, cld_macmic_ztodt, ptend ) - logical :: lq(pcnst) + ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend + call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) + call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) + call physics_ptend_dealloc(ptend_aero_sc) - !----------------------------------------------------------------------- + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) - call t_startf('bc_init') + if ( (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state_sc, ptend_sc, ztodt, tend_sc) - zero = 0._r8 - zero_tracers(:,:) = 0._r8 - zero_sc(:) = 0._r8 + if (trim(cam_take_snapshot_after) == "microp_driver_tend_subcol") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state_sc, tend_sc, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - lchnk = state%lchnk - ncol = state%ncol + call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & + nstep, ztodt, zero_sc, & + prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & + snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) - rtdt = 1._r8/ztodt + call physics_state_dealloc(state_sc) + call physics_tend_dealloc(tend_sc) + call physics_ptend_dealloc(ptend_sc) + else + call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) + end if + ! combine aero and micro tendencies for the grid + call physics_ptend_sum(ptend_aero, ptend, ncol) + call physics_ptend_dealloc(ptend_aero) - nstep = get_nstep() + ! Have to scale and apply for full timestep to get tend right + ! (see above note for macrophysics). + call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) + call diag_clip_tend_writeout(state, ptend, ncol, lchnk, ixcldliq, ixcldice, ixq, ztodt, rtdt) - call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) + if ( (trim(cam_take_snapshot_after) == "microp_section") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if + call physics_update (state, ptend, ztodt, tend) - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - call pbuf_get_field(pbuf, totliqini_idx, totliqini) - call pbuf_get_field(pbuf, toticeini_idx, toticeini) + if (trim(cam_take_snapshot_after) == "microp_section") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - call pbuf_get_field(pbuf, dtcore_idx, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dqcore_idx, dqcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, ducore_idx, ducore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, dvcore_idx, dvcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & + zero, prec_str(:ncol)/cld_macmic_num_steps, & + snow_str(:ncol)/cld_macmic_num_steps, zero) - ifld = pbuf_get_index('FRACIS') - call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - fracis (:ncol,:,1:pcnst) = 1._r8 + call t_stopf('microp_tend') + prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) + snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) + prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) + snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) - ! Set physics tendencies to 0 - tend%dTdt(:ncol,:pver) = 0._r8 - tend%dudt(:ncol,:pver) = 0._r8 - tend%dvdt(:ncol,:pver) = 0._r8 + end do ! end substepping over macrophysics/microphysics - ! Verify state coming from the dynamics - if (state_debug_checks) then - call physics_state_check(state, name="before tphysbc (dycore?)") - end if + call outfld( 'UTEND_MACROP', ptend_macp_all%u, pcols, lchnk) + call outfld( 'VTEND_MACROP', ptend_macp_all%v, pcols, lchnk) + call physics_ptend_dealloc(ptend_macp_all) - call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) + prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps + snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps + prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps + snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps + prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) + snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) - ! Since clybry_fam_adj operates directly on the tracers, and has no - ! physics_update call, re-run qneg3. - call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,state%q ) + endif - ! Validate output of clybry_fam_adj. - if (state_debug_checks) then - call physics_state_check(state, name="clybry_fam_adj") + ! Add the precipitation from CARMA to the precipitation from stratiform. + if (carma_do_cldice .or. carma_do_cldliq) then + prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) + snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) end if - ! - ! Dump out "before physics" state - ! - call diag_state_b4_phys_write (state) - ! compute mass integrals of input tracers state - call check_tracers_init(state, tracerint) + if ( .not. deep_scheme_does_scav_trans() ) then - call t_stopf('bc_init') + ! ------------------------------------------------------------------------------- + ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. + ! 2. Convective Transport of Non-Water Aerosol Species. + ! + ! . Aerosol wet chemistry determines scavenging fractions, and transformations + ! . Then do convective transport of all trace species except qv,ql,qi. + ! . We needed to do the scavenging first to determine the interstitial fraction. + ! . When UNICON is used as unified convection, we should still perform + ! wet scavenging but not 'convect_deep_tend2'. + ! ------------------------------------------------------------------------------- - !=================================================== - ! Global mean total energy fixer - !=================================================== - call t_startf('energy_fixer') + call t_startf('bc_aerosols') + if (clim_modal_aero .and. .not. prog_modal_aero) then + call modal_aero_calcsize_diag(state, pbuf) + call modal_aero_wateruptake_dr(state, pbuf) + endif - call tot_energy_phys(state, 'phBF') - call tot_energy_phys(state, 'dyBF',vc=vc_dycore) + if (trim(cam_take_snapshot_before) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - if (.not.dycore_is('EUL')) then - call check_energy_fix(state, ptend, nstep, flx_heat) + call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) + if ( (trim(cam_take_snapshot_after) == "aero_model_wetdep") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) + end if call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) - end if - call tot_energy_phys(state, 'phBP') - call tot_energy_phys(state, 'dyBP',vc=vc_dycore) - ! Save state for convective tendency calculations. - call diag_conv_tend_ini(state, pbuf) + if (trim(cam_take_snapshot_after) == "aero_model_wetdep") then + call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) + end if - call cnst_get_ind('Q', ixq) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - qini (:ncol,:pver) = state%q(:ncol,:pver, ixq) - cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + if (carma_do_wetdep) then + ! CARMA wet deposition + ! + ! NOTE: It needs to follow aero_model_wetdep, so that cam_out%xxxwetxxx + ! fields have already been set for CAM aerosols and cam_out can be added + ! to for CARMA aerosols. + call t_startf ('carma_wetdep_tend') + call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('carma_wetdep_tend') + end if - totliqini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_liq_num - m = thermodynamic_active_species_liq_idx(m_cnst) - totliqini(:ncol,:pver) = totliqini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do - toticeini(:ncol,:pver) = 0.0_r8 - do m_cnst=1,thermodynamic_active_species_ice_num - m = thermodynamic_active_species_ice_idx(m_cnst) - toticeini(:ncol,:pver) = toticeini(:ncol,:pver)+state%q(:ncol,:pver,m) - end do + call t_startf ('convect_deep_tend2') + call convect_deep_tend_2( state, ptend, ztodt, pbuf ) + call physics_update(state, ptend, ztodt, tend) + call t_stopf ('convect_deep_tend2') + ! check tracer integrals + call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) - call outfld('TEOUT', teout , pcols, lchnk ) - call outfld('TEINP', state%te_ini(:,dyn_te_idx), pcols, lchnk ) - call outfld('TEFIX', state%te_cur(:,dyn_te_idx), pcols, lchnk ) + call t_stopf('bc_aerosols') - ! T, U, V tendency due to dynamics - if ( nstep > dyn_time_lvls-1 ) then - dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt - dqcore(:ncol,:pver) = (state%q(:ncol,:pver,ixq) - dqcore(:ncol,:pver))/ztodt - ducore(:ncol,:pver) = (state%u(:ncol,:pver) - ducore(:ncol,:pver))/ztodt - dvcore(:ncol,:pver) = (state%v(:ncol,:pver) - dvcore(:ncol,:pver))/ztodt - call outfld( 'DTCORE', dtcore, pcols, lchnk ) - call outfld( 'DQCORE', dqcore, pcols, lchnk ) - call outfld( 'UTEND_CORE', ducore, pcols, lchnk ) - call outfld( 'VTEND_CORE', dvcore, pcols, lchnk ) - end if + endif - call t_stopf('energy_fixer') - ! !=================================================== - ! Dry adjustment + ! Moist physical parameteriztions complete: + ! send dynamical variables, and derived variables to history file !=================================================== - call t_startf('dry_adjustment') - if (trim(cam_take_snapshot_before) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if + call t_startf('bc_history_write') + call diag_phys_writeout(state, pbuf) + call diag_conv(state, ztodt, pbuf) - call dadadj_tend(ztodt, state, ptend) + call t_stopf('bc_history_write') - if ( (trim(cam_take_snapshot_after) == "dadadj_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - call physics_update(state, ptend, ztodt, tend) + !=================================================== + ! Write cloud diagnostics on history file + !=================================================== - if (trim(cam_take_snapshot_after) == "dadadj_tend") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if + call t_startf('bc_cld_diag_history_write') - call t_stopf('dry_adjustment') + call cloud_diagnostics_calc(state, pbuf) + + call t_stopf('bc_cld_diag_history_write') !=================================================== - ! Moist convection + ! Radiation computations !=================================================== - call t_startf('moist_convection') - - call t_startf ('convect_deep_tend') + call t_startf('radiation') - if (trim(cam_take_snapshot_before) == "convect_deep_tend") then + if (trim(cam_take_snapshot_before) == "radiation_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - call convect_deep_tend( & - cmfmc, cmfcme, & - pflx, zdu, & - rliq, rice, & - ztodt, & - state, ptend, cam_in%landfrac, pbuf) + call radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx) - if ( (trim(cam_take_snapshot_after) == "convect_deep_tend") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if + ! Set net flux used by spectral dycores + do i=1,ncol + tend%flx_net(i) = net_flx(i) + end do - if ( ptend%lu ) then - call outfld( 'UTEND_DCONV', ptend%u, pcols, lchnk) - end if - if ( ptend%lv ) then - call outfld( 'VTEND_DCONV', ptend%v, pcols, lchnk) + if ( (trim(cam_take_snapshot_after) == "radiation_tend") .and. & + (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then + call cam_snapshot_ptend_outfld(ptend, lchnk) end if call physics_update(state, ptend, ztodt, tend) - if (trim(cam_take_snapshot_after) == "convect_deep_tend") then + if (trim(cam_take_snapshot_after) == "radiation_tend") then call cam_snapshot_all_outfld_tphysbc(cam_snapshot_after_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - - call t_stopf('convect_deep_tend') - - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) - - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) - - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) - end if - - ! Check energy integrals, including "reserved liquid" - flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) - snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) - call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) - snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) - - !=================================================== - ! Compute convect diagnostics - !=================================================== - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 + flx_heat, cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, det_s, det_ice, net_flx) end if - if (trim(cam_take_snapshot_before) == "convect_diagnostics_calc") then - call cam_snapshot_all_outfld_tphysbc(cam_snapshot_before_num, state, tend, cam_in, cam_out, pbuf, & - cmfmc, cmfcme, pflx, zdu, rliq, rice, dlf, dlf2, rliq2, net_flx) - end if - call convect_diagnostics_calc (ztodt , cmfmc, & - dlf , dlf2 , rliq , rliq2, & - state , pbuf) - if ( (trim(cam_take_snapshot_after) == "convect_diagnostics_calc") .and. & - (trim(cam_take_snapshot_before) == trim(cam_take_snapshot_after))) then - call cam_snapshot_ptend_outfld(ptend, lchnk) - end if - - ! add reserve liquid to pbuf - call pbuf_get_field(pbuf, rliqbc_idx, rliqbc) - rliqbc(:ncol) = rliq(:ncol) - - call t_stopf('moist_convection') - - if (is_first_step()) then - - !initiailize sedimentation arrays - prec_pcw = 0._r8 - snow_pcw = 0._r8 - prec_sed = 0._r8 - snow_sed = 0._r8 - prec_str = 0._r8 - snow_str = 0._r8 - - if (is_subcol_on()) then - prec_str_sc = 0._r8 - snow_str_sc = 0._r8 - end if - - !=================================================== - ! Run wet deposition routines to intialize aerosols - !=================================================== - - call modal_aero_calcsize_diag(state, pbuf) - call modal_aero_wateruptake_dr(state, pbuf) - - !=================================================== - ! Radiation computations - ! initialize fluxes only, do not update state - !=================================================== + call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) + call t_stopf('radiation') - end if + ! Diagnose the location of the tropopause and its location to the history file(s). + call t_startf('tropopause') + call tropopause_output(state) + call t_stopf('tropopause') ! Save atmospheric fields to force surface models call t_startf('cam_export') @@ -2897,6 +2923,8 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use physics_buffer, only: physics_buffer_desc use carma_intr, only: carma_timestep_init use ghg_data, only: ghg_data_timestep_init + use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_timestep_init + use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_timestep_init use aoa_tracers, only: aoa_tracers_timestep_init use vertical_diffusion, only: vertical_diffusion_ts_init use radheat, only: radheat_timestep_init @@ -2960,6 +2988,12 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) ! prescribed aerosol deposition fluxes call aerodep_flx_adv(phys_state, pbuf2d, cam_out) + ! CAM3 prescribed aerosol masses + if (cam3_aero_data_on) call cam3_aero_data_timestep_init(pbuf2d, phys_state) + + ! CAM3 prescribed ozone data + if (cam3_ozone_data_on) call cam3_ozone_data_timestep_init(pbuf2d, phys_state) + ! Time interpolate data models of gasses in pbuf2d call ghg_data_timestep_init(pbuf2d, phys_state) From e4f97ea6e6444ef5e5d760b9240e76f987dfc3a4 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 26 Nov 2023 11:38:53 -0700 Subject: [PATCH 06/75] external updates for scam_dev 6_3_136 --- Externals.cfg | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 6ddeced6ce..7ccaf9be59 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -21,14 +21,14 @@ externals = Externals.cfg required = True [cmeps] -branch = cmeps0.14.34_scamdev +branch = cmeps0.14.43_scamdev protocol = git repo_url = https://github.com/jtruesdal/CMEPS.git local_path = components/cmeps required = True [cdeps] -branch = cdeps1.0.14_scamdev +branch = cdeps1.0.24_scamdev protocol = git repo_url = https://github.com/jtruesdal/CDEPS.git local_path = components/cdeps @@ -79,7 +79,7 @@ externals = Externals_CISM.cfg required = True [clm] -tag = ctsm5.1.dev124_scamdev +tag = ctsm5.1.dev142_scamdev protocol = git repo_url = https://github.com/jtruesdal/ctsm local_path = components/clm From 64aa11ea2b796723b21e1691fdd0447d0b1d1e92 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 26 Nov 2023 11:41:22 -0700 Subject: [PATCH 07/75] missed cice external update for scam --- Externals.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals.cfg b/Externals.cfg index 7ccaf9be59..7a75f447e6 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -13,7 +13,7 @@ local_path = components/cice5 required = True [cice6] -tag = cesm_cice6_4_1_8_scamdev +tag = cesm_cice6_4_1_10_scamdev protocol = git repo_url = https://github.com/jtruesdal/CESM_CICE local_path = components/cice From b6ee97c9b358fcb8fcff7f7ea04986cb4463d92e Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 26 Nov 2023 12:27:17 -0700 Subject: [PATCH 08/75] scam se update --- Externals.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals.cfg b/Externals.cfg index 7a75f447e6..dd15eece30 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -45,7 +45,7 @@ required = True [share] tag = share1.0.17 protocol = git -repo_url = https://github.com/ESCOMP/CESM_share +repo_url = https://github.com/jtruesdal/CESM_share local_path = share required = True From 5a9159a33f184f0e2cef578dd687c44817aca9d3 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Wed, 3 Jan 2024 15:05:02 -0700 Subject: [PATCH 09/75] scam se updates --- bld/configure | 4 +- bld/namelist_files/namelist_defaults_cam.xml | 11 +- .../usermods_dirs/scam_arm95/shell_commands | 15 +- .../usermods_dirs/scam_arm95/user_nl_cam | 3 +- .../usermods_dirs/scam_arm97/shell_commands | 13 +- .../usermods_dirs/scam_arm97/user_nl_cam | 1 - .../usermods_dirs/scam_atex/shell_commands | 13 +- .../usermods_dirs/scam_atex/user_nl_cam | 1 - .../usermods_dirs/scam_bomex/shell_commands | 13 +- .../usermods_dirs/scam_bomex/user_nl_cam | 1 - .../scam_cgilsS11/shell_commands | 13 +- .../usermods_dirs/scam_cgilsS11/user_nl_cam | 1 - .../scam_cgilsS12/shell_commands | 13 +- .../usermods_dirs/scam_cgilsS12/user_nl_cam | 1 - .../usermods_dirs/scam_cgilsS6/shell_commands | 13 +- .../usermods_dirs/scam_cgilsS6/user_nl_cam | 1 - .../scam_dycomsRF01/shell_commands | 13 +- .../usermods_dirs/scam_dycomsRF01/user_nl_cam | 1 - .../scam_dycomsRF02/shell_commands | 13 +- .../usermods_dirs/scam_dycomsRF02/user_nl_cam | 1 - .../usermods_dirs/scam_gateIII/shell_commands | 13 +- .../usermods_dirs/scam_gateIII/user_nl_cam | 1 - .../scam_mandatory/shell_commands | 6 + .../scam_micre2017/shell_commands | 13 +- .../usermods_dirs/scam_micre2017/user_nl_cam | 1 - .../usermods_dirs/scam_mpace/shell_commands | 13 +- .../usermods_dirs/scam_mpace/user_nl_cam | 1 - .../usermods_dirs/scam_rico/shell_commands | 13 +- .../usermods_dirs/scam_rico/user_nl_cam | 1 - .../scam_sparticus/shell_commands | 13 +- .../usermods_dirs/scam_sparticus/user_nl_cam | 1 - .../usermods_dirs/scam_togaII/shell_commands | 13 +- .../usermods_dirs/scam_togaII/user_nl_cam | 1 - .../usermods_dirs/scam_twp06/shell_commands | 13 +- .../usermods_dirs/scam_twp06/user_nl_cam | 1 - src/control/cam_comp.F90 | 15 +- src/control/cam_history.F90 | 23 +- src/control/history_defaults.F90 | 155 ------- src/control/history_scam.F90 | 208 +++++++-- src/control/ncdio_atm.F90 | 54 ++- src/control/scamMod.F90 | 424 +++++------------- src/cpl/nuopc/atm_comp_nuopc.F90 | 4 - src/cpl/nuopc/atm_stream_ndep.F90 | 25 -- src/dynamics/eul/diag_dynvar_ic.F90 | 26 +- src/dynamics/eul/dp_coupling.F90 | 2 +- src/dynamics/eul/dyn_comp.F90 | 23 +- src/dynamics/eul/dyn_grid.F90 | 105 ----- src/dynamics/eul/dynpkg.F90 | 36 +- src/dynamics/eul/iop.F90 | 30 +- src/dynamics/eul/restart_dynamics.F90 | 68 ++- src/dynamics/eul/scmforecast.F90 | 167 ++++--- src/dynamics/eul/stepon.F90 | 12 +- src/dynamics/eul/tfilt_massfix.F90 | 136 +++--- src/dynamics/se/apply_iop_forcing.F90 | 142 +----- src/dynamics/se/dycore/prim_advance_mod.F90 | 2 - src/dynamics/se/dycore/prim_driver_mod.F90 | 63 ++- src/dynamics/se/dyn_comp.F90 | 270 ++++++----- src/dynamics/se/dyn_grid.F90 | 45 +- src/dynamics/se/se_single_column_mod.F90 | 179 +++----- src/dynamics/se/stepon.F90 | 160 +++---- src/infrastructure/phys_grid.F90 | 94 +--- src/physics/cam/cam_diagnostics.F90 | 34 +- src/physics/cam/check_energy.F90 | 45 +- src/physics/cam/clubb_intr.F90 | 16 +- src/physics/cam/convect_shallow.F90 | 113 ++--- src/physics/cam/phys_grid.F90 | 24 +- src/physics/cam/physpkg.F90 | 14 +- src/physics/cam_dev/physpkg.F90 | 14 +- src/utils/hybvcoord_mod.F90 | 28 ++ 69 files changed, 1263 insertions(+), 1742 deletions(-) delete mode 100644 src/control/history_defaults.F90 create mode 100644 src/utils/hybvcoord_mod.F90 diff --git a/bld/configure b/bld/configure index 9a68f199c1..d00aa228f6 100755 --- a/bld/configure +++ b/bld/configure @@ -1207,10 +1207,10 @@ if (defined $opts{'camiop'}) { } my $camiop = $cfg_ref->get('camiop') ? "ON" : "OFF"; -# The only dycore supported in CAMIOP mode is Eulerian +# The only dycores supported in SCAM mode are Eulerian and Spectral Elements if ($camiop eq 'ON' and !($dyn_pkg eq 'eul' or $dyn_pkg eq 'se')) { die <<"EOF"; -** ERROR: CAMIOP mode only works with Eulerian dycore. +** ERROR: CAMIOP mode only works with the Eulerian or Spectral Element dycores. ** Requested dycore is: $dyn_pkg EOF } diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 7e72687612..b56650626c 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -1902,7 +1902,7 @@ atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc -atm/cam/chem/trop_mam/atmsrf_ne16pg3_230520.nc +atm/cam/chem/trop_mam/atmsrf_ne16pg3_c230520.nc atm/cam/chem/trop_mam/atmsrf_ne30np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne30np4.pg2_200108.nc atm/cam/chem/trop_mam/atmsrf_ne30pg3_180522.nc @@ -2860,15 +2860,16 @@ -atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc -atm/cam/scam/iop/ARM97_4scam.nc +atm/cam/inic/gaus/cami_0000-09-01_64x128_L30_c031210.nc +atm/cam/scam/iop/ARM97_4scam.nc 1500 9 .true. + 0.0D0 slt -atm/cam/inic/homme/cami_mam3_Linoz_ne4np4_L72_c160909.nc -atm/cam/scam/iop/TOGAII_4scam.nc +atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc +allsame diff --git a/cime_config/usermods_dirs/scam_arm95/shell_commands b/cime_config/usermods_dirs/scam_arm95/shell_commands index e902f2be49..d1d1835780 100755 --- a/cime_config/usermods_dirs/scam_arm95/shell_commands +++ b/cime_config/usermods_dirs/scam_arm95/shell_commands @@ -1,4 +1,4 @@ -# setup SCAM lon and lat for this iop +# setup SCAM lon and lat for this iop # this should correspond to the forcing IOP coordinates ./xmlchange PTS_LON=262.5 ./xmlchange PTS_LAT=36.6 @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1995-07-18 ./xmlchange START_TOD=19800 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=1259 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=418 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_arm95/user_nl_cam b/cime_config/usermods_dirs/scam_arm95/user_nl_cam index 591b415e0d..9942da7a07 100644 --- a/cime_config/usermods_dirs/scam_arm95/user_nl_cam +++ b/cime_config/usermods_dirs/scam_arm95/user_nl_cam @@ -1,11 +1,10 @@ -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/ARM95_4scam.nc" mfilt=1500 nhtfrq=1 co2vmr=368.9e-6 scm_use_obs_uv = .true. scm_relaxation = .true. -scm_relax_fincl = 'T', 'bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', +scm_relax_fincl = 'T','bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', 'ncl_a3', 'num_a1', 'num_a2', 'num_a3', 'num_a4', 'pom_a1', 'pom_a4', 'so4_a1', 'so4_a2', 'so4_a3', 'soa_a1', 'soa_a2' scm_relax_bot_p = 105000. diff --git a/cime_config/usermods_dirs/scam_arm97/shell_commands b/cime_config/usermods_dirs/scam_arm97/shell_commands index a695db6d58..ec0b5aeaf6 100755 --- a/cime_config/usermods_dirs/scam_arm97/shell_commands +++ b/cime_config/usermods_dirs/scam_arm97/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1997-06-18 ./xmlchange START_TOD=84585 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=2088 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=695 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-06-01-00000.nc"' +fi +cat >> user_nl_cam << EOF +ncdata=$ncdata +EOF # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_arm97/user_nl_cam b/cime_config/usermods_dirs/scam_arm97/user_nl_cam index 3327b2c69a..442ad02681 100644 --- a/cime_config/usermods_dirs/scam_arm97/user_nl_cam +++ b/cime_config/usermods_dirs/scam_arm97/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/ARM97_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-06-01-00000.nc" mfilt=2088 nhtfrq=1 co2vmr=368.9e-6 diff --git a/cime_config/usermods_dirs/scam_atex/shell_commands b/cime_config/usermods_dirs/scam_atex/shell_commands index cea0583b9b..82b3d542f9 100755 --- a/cime_config/usermods_dirs/scam_atex/shell_commands +++ b/cime_config/usermods_dirs/scam_atex/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1969-02-15 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=2 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=47 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-02-01-00000.nc""' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_atex/user_nl_cam b/cime_config/usermods_dirs/scam_atex/user_nl_cam index d658f99157..11c7df976a 100644 --- a/cime_config/usermods_dirs/scam_atex/user_nl_cam +++ b/cime_config/usermods_dirs/scam_atex/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/ATEX_48hr_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-02-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_bomex/shell_commands b/cime_config/usermods_dirs/scam_bomex/shell_commands index 6d2bb04886..f4304ff910 100755 --- a/cime_config/usermods_dirs/scam_bomex/shell_commands +++ b/cime_config/usermods_dirs/scam_bomex/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1969-06-25 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=5 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=119 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-06-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_bomex/user_nl_cam b/cime_config/usermods_dirs/scam_bomex/user_nl_cam index e9132902b8..c92e75acf1 100644 --- a/cime_config/usermods_dirs/scam_bomex/user_nl_cam +++ b/cime_config/usermods_dirs/scam_bomex/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/BOMEX_5day_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-06-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_cgilsS11/shell_commands b/cime_config/usermods_dirs/scam_cgilsS11/shell_commands index 37056ed761..9718a27ecb 100755 --- a/cime_config/usermods_dirs/scam_cgilsS11/shell_commands +++ b/cime_config/usermods_dirs/scam_cgilsS11/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1997-07-15 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=30 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=719 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_cgilsS11/user_nl_cam b/cime_config/usermods_dirs/scam_cgilsS11/user_nl_cam index c58ac57499..7472fcb0f8 100644 --- a/cime_config/usermods_dirs/scam_cgilsS11/user_nl_cam +++ b/cime_config/usermods_dirs/scam_cgilsS11/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/S11_CTL_MixedLayerInit_reduced.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_cgilsS12/shell_commands b/cime_config/usermods_dirs/scam_cgilsS12/shell_commands index fefce8216e..b5a142791e 100755 --- a/cime_config/usermods_dirs/scam_cgilsS12/shell_commands +++ b/cime_config/usermods_dirs/scam_cgilsS12/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1997-07-15 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=30 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=719 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_cgilsS12/user_nl_cam b/cime_config/usermods_dirs/scam_cgilsS12/user_nl_cam index 52e9e20093..4273f0afa6 100644 --- a/cime_config/usermods_dirs/scam_cgilsS12/user_nl_cam +++ b/cime_config/usermods_dirs/scam_cgilsS12/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/S12_CTL_MixedLayerInit_reduced.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_cgilsS6/shell_commands b/cime_config/usermods_dirs/scam_cgilsS6/shell_commands index 5ecc09e2a4..7f12a5d704 100755 --- a/cime_config/usermods_dirs/scam_cgilsS6/shell_commands +++ b/cime_config/usermods_dirs/scam_cgilsS6/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1997-07-15 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=30 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=719 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_cgilsS6/user_nl_cam b/cime_config/usermods_dirs/scam_cgilsS6/user_nl_cam index 6b2a0222f4..cc5edec3c5 100644 --- a/cime_config/usermods_dirs/scam_cgilsS6/user_nl_cam +++ b/cime_config/usermods_dirs/scam_cgilsS6/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/S6_CTL_reduced.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_dycomsRF01/shell_commands b/cime_config/usermods_dirs/scam_dycomsRF01/shell_commands index 241e785227..598d7b0e67 100755 --- a/cime_config/usermods_dirs/scam_dycomsRF01/shell_commands +++ b/cime_config/usermods_dirs/scam_dycomsRF01/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1999-07-11 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=144 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=47 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_dycomsRF01/user_nl_cam b/cime_config/usermods_dirs/scam_dycomsRF01/user_nl_cam index 76a2c10c55..28808a7ff5 100644 --- a/cime_config/usermods_dirs/scam_dycomsRF01/user_nl_cam +++ b/cime_config/usermods_dirs/scam_dycomsRF01/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/DYCOMSrf01_4day_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_dycomsRF02/shell_commands b/cime_config/usermods_dirs/scam_dycomsRF02/shell_commands index 241e785227..598d7b0e67 100755 --- a/cime_config/usermods_dirs/scam_dycomsRF02/shell_commands +++ b/cime_config/usermods_dirs/scam_dycomsRF02/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1999-07-11 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=144 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=47 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_dycomsRF02/user_nl_cam b/cime_config/usermods_dirs/scam_dycomsRF02/user_nl_cam index 57ebe708ed..8def7e8c28 100644 --- a/cime_config/usermods_dirs/scam_dycomsRF02/user_nl_cam +++ b/cime_config/usermods_dirs/scam_dycomsRF02/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/DYCOMSrf02_48hr_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_gateIII/shell_commands b/cime_config/usermods_dirs/scam_gateIII/shell_commands index 03642e292a..7af5fb4632 100755 --- a/cime_config/usermods_dirs/scam_gateIII/shell_commands +++ b/cime_config/usermods_dirs/scam_gateIII/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1974-08-30 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=1440 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=479 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-08-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_gateIII/user_nl_cam b/cime_config/usermods_dirs/scam_gateIII/user_nl_cam index 96e7b2ddbc..ef272cc251 100644 --- a/cime_config/usermods_dirs/scam_gateIII/user_nl_cam +++ b/cime_config/usermods_dirs/scam_gateIII/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/GATEIII_4scam_c170809.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-08-01-00000.nc" mfilt=1440 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index 4ef1d80592..0af79f293f 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -4,6 +4,12 @@ # # SCAM works in SPMD mode with a single task. ./xmlchange NTASKS=1 + # SCAM doesn't have restart functionality yet. ./xmlchange REST_OPTION=never +# Note that clm cannot use initial conditions with SCAM -so will only use specified phenology +# Only change if CLM_FORCE_COLDSTART exists and dycore is eularian +if [ `./xmlquery --value CAM_DYCORE` == 'eul' ] && [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then +./xmlchange CLM_FORCE_COLDSTART='on' +fi diff --git a/cime_config/usermods_dirs/scam_micre2017/shell_commands b/cime_config/usermods_dirs/scam_micre2017/shell_commands index b7b2225466..574bc25a2a 100755 --- a/cime_config/usermods_dirs/scam_micre2017/shell_commands +++ b/cime_config/usermods_dirs/scam_micre2017/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=2017-01-01 ./xmlchange START_TOD=0000 -./xmlchange STOP_OPTION=ndays -./xmlchange STOP_N=90 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=2159 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.Gaus_64x128.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_micre2017/user_nl_cam b/cime_config/usermods_dirs/scam_micre2017/user_nl_cam index 675974b5e7..99ee932792 100644 --- a/cime_config/usermods_dirs/scam_micre2017/user_nl_cam +++ b/cime_config/usermods_dirs/scam_micre2017/user_nl_cam @@ -1,5 +1,4 @@ iopfile='$DIN_LOC_ROOT/atm/cam/scam/iop/micre2017_3mo.macquarie2017.iop.nc' -ncdata ='$DIN_LOC_ROOT/atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.Gaus_64x128.nc' mfilt=9000 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_mpace/shell_commands b/cime_config/usermods_dirs/scam_mpace/shell_commands index d9d0e50837..83dce10ce4 100755 --- a/cime_config/usermods_dirs/scam_mpace/shell_commands +++ b/cime_config/usermods_dirs/scam_mpace/shell_commands @@ -9,8 +9,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=2004-10-05 ./xmlchange START_TOD=7171 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=1242 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=413 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-10-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_mpace/user_nl_cam b/cime_config/usermods_dirs/scam_mpace/user_nl_cam index cb3263e871..41d20b4b8e 100644 --- a/cime_config/usermods_dirs/scam_mpace/user_nl_cam +++ b/cime_config/usermods_dirs/scam_mpace/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/MPACE_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-10-01-00000.nc" mfilt=1242 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_rico/shell_commands b/cime_config/usermods_dirs/scam_rico/shell_commands index ad424f951b..bc7ea7f2af 100755 --- a/cime_config/usermods_dirs/scam_rico/shell_commands +++ b/cime_config/usermods_dirs/scam_rico/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1995-07-15 ./xmlchange START_TOD=0 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=216 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=71 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_rico/user_nl_cam b/cime_config/usermods_dirs/scam_rico/user_nl_cam index 968b1e3c71..e269abb5a5 100644 --- a/cime_config/usermods_dirs/scam_rico/user_nl_cam +++ b/cime_config/usermods_dirs/scam_rico/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/RICO_3day_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-07-01-00000.nc" mfilt=2088 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_sparticus/shell_commands b/cime_config/usermods_dirs/scam_sparticus/shell_commands index 68dbd4467c..560796904d 100755 --- a/cime_config/usermods_dirs/scam_sparticus/shell_commands +++ b/cime_config/usermods_dirs/scam_sparticus/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=2010-04-01 ./xmlchange START_TOD=3599 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=2156 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=717 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-04-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_sparticus/user_nl_cam b/cime_config/usermods_dirs/scam_sparticus/user_nl_cam index d12c7a3609..1b8f3a1fab 100644 --- a/cime_config/usermods_dirs/scam_sparticus/user_nl_cam +++ b/cime_config/usermods_dirs/scam_sparticus/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/SPARTICUS_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-04-01-00000.nc" mfilt=2156 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_togaII/shell_commands b/cime_config/usermods_dirs/scam_togaII/shell_commands index 6ab21646b1..5116a2324a 100755 --- a/cime_config/usermods_dirs/scam_togaII/shell_commands +++ b/cime_config/usermods_dirs/scam_togaII/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=1992-12-18 ./xmlchange START_TOD=64800 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=1512 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=503 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-12-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_togaII/user_nl_cam b/cime_config/usermods_dirs/scam_togaII/user_nl_cam index f6a36ad6eb..dc09c1b829 100644 --- a/cime_config/usermods_dirs/scam_togaII/user_nl_cam +++ b/cime_config/usermods_dirs/scam_togaII/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/TOGAII_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-12-01-00000.nc" mfilt=9 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/cime_config/usermods_dirs/scam_twp06/shell_commands b/cime_config/usermods_dirs/scam_twp06/shell_commands index 7787ba2453..027b1d672d 100755 --- a/cime_config/usermods_dirs/scam_twp06/shell_commands +++ b/cime_config/usermods_dirs/scam_twp06/shell_commands @@ -8,8 +8,17 @@ # but you may simulate any within the IOP start and end times. ./xmlchange RUN_STARTDATE=2006-01-17 ./xmlchange START_TOD=10800 -./xmlchange STOP_OPTION=nsteps -./xmlchange STOP_N=1926 +./xmlchange STOP_OPTION=nhours +./xmlchange STOP_N=641 + +if [ `./xmlquery --value CAM_DYCORE` == 'se' ]; then + ncdata='"$DIN_LOC_ROOT/atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc"' +else + ncdata='"$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-01-01-00000.nc"' +fi +cat >> user_nl_cam << eof +ncdata=$ncdata +eof # usermods_dir/scam_mandatory will be included for all single column # runs by default. This usermods directory contains mandatory settings diff --git a/cime_config/usermods_dirs/scam_twp06/user_nl_cam b/cime_config/usermods_dirs/scam_twp06/user_nl_cam index 565a384502..d7b4cc2537 100644 --- a/cime_config/usermods_dirs/scam_twp06/user_nl_cam +++ b/cime_config/usermods_dirs/scam_twp06/user_nl_cam @@ -1,5 +1,4 @@ iopfile="$DIN_LOC_ROOT/atm/cam/scam/iop/TWP06_4scam.nc" -ncdata="$DIN_LOC_ROOT/atm/cam/scam/iop/CESM2.F2000climo.IOP_SITES.cam.i.0003-01-01-00000.nc" mfilt=1926 nhtfrq=1 scm_use_obs_uv = .true. diff --git a/src/control/cam_comp.F90 b/src/control/cam_comp.F90 index 9982df6d2c..a040762067 100644 --- a/src/control/cam_comp.F90 +++ b/src/control/cam_comp.F90 @@ -70,7 +70,6 @@ subroutine cam_init( & ! !----------------------------------------------------------------------- - use history_defaults, only: bldfld use cam_initfiles, only: cam_initfiles_open use dyn_grid, only: dyn_grid_init use phys_grid, only: phys_grid_init @@ -81,15 +80,12 @@ subroutine cam_init( & use stepon, only: stepon_init use ionosphere_interface, only: ionosphere_init use camsrfexch, only: hub2atm_alloc, atm2hub_alloc - use cam_history, only: intht - use history_scam, only: scm_intht + use cam_history, only: intht, write_camiop + use history_scam, only: scm_intht, initialize_iop_history use cam_pio_utils, only: init_pio_subsystem use cam_instance, only: inst_suffix use cam_snapshot_common, only: cam_snapshot_deactivate use air_composition, only: air_composition_init -#if (defined BFB_CAM_SCAM_IOP) - use history_defaults, only: initialize_iop_history -#endif use phys_grid_ctem, only: phys_grid_ctem_reg ! Arguments @@ -193,14 +189,11 @@ subroutine cam_init( & call cam_read_restart(cam_in, cam_out, dyn_in, dyn_out, pbuf2d, stop_ymd, stop_tod) -#if (defined BFB_CAM_SCAM_IOP) - call initialize_iop_history() -#endif end if - call phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) + if (write_camiop) call initialize_iop_history() - call bldfld () ! master field list (if branch, only does hash tables) + call phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call stepon_init(dyn_in, dyn_out) diff --git a/src/control/cam_history.F90 b/src/control/cam_history.F90 index 2bc71d4bd7..484c01a705 100644 --- a/src/control/cam_history.F90 +++ b/src/control/cam_history.F90 @@ -170,6 +170,7 @@ module cam_history character(len=16) :: host ! host name character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or ! 'YEARLY' then write IC file + logical :: write_camiop = .false. ! setup to use iop fields if true. logical :: inithist_all = .false. ! Flag to indicate set of fields to be ! included on IC file ! .false. include only required fields @@ -303,8 +304,9 @@ module cam_history module procedure addfld_nd end interface - ! Needed by cam_diagnostics - public :: inithist_all + + public :: inithist_all ! Needed by cam_diagnostics + public :: write_camiop ! Needed by cam_comp integer :: lcltod_start(ptapes) ! start time of day for local time averaging (sec) integer :: lcltod_stop(ptapes) ! stop time of day for local time averaging, stop > start is wrap around (sec) @@ -823,7 +825,8 @@ subroutine history_readnl(nlfile) else if (inithist == 'YEARLY' ) then write(iulog,*)'Initial conditions history files will be written yearly.' else if (inithist == 'CAMIOP' ) then - write(iulog,*)'Initial conditions history files will be written for IOP.' + write_camiop=.true. + write(iulog,*)'Initial conditions history files will be written for IOP.' else if (inithist == 'ENDOFRUN' ) then write(iulog,*)'Initial conditions history files will be written at end of run.' else @@ -3948,8 +3951,10 @@ subroutine h_inquire (t) ierr=pio_inq_varid (tape(t)%File,'date_written',tape(t)%date_writtenid) ierr=pio_inq_varid (tape(t)%File,'time_written',tape(t)%time_writtenid) #if ( defined BFB_CAM_SCAM_IOP ) + if (write_camiop) then ierr=pio_inq_varid (tape(t)%File,'tsec ',tape(t)%tsecid) ierr=pio_inq_varid (tape(t)%File,'bdate ',tape(t)%bdateid) + end if #endif if (.not. is_initfile(file_index=t) ) then ! Don't write the GHG/Solar forcing data to the IC file. It is never @@ -4339,7 +4344,7 @@ subroutine h_define (t, restart) ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'Conventions', trim(str)) ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'source', 'CAM') #if ( defined BFB_CAM_SCAM_IOP ) - ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'CAM_GENERATED_FORCING','create SCAM IOP dataset') + if (write_camiop) ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'CAM_GENERATED_FORCING','create SCAM IOP dataset') #endif ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'case',caseid) ierr=pio_put_att (tape(t)%File, PIO_GLOBAL, 'logname',logname) @@ -4414,9 +4419,11 @@ subroutine h_define (t, restart) ierr=pio_put_att (tape(t)%File, tape(t)%nbdateid, 'long_name', trim(str)) #if ( defined BFB_CAM_SCAM_IOP ) + if (write_camiop) then ierr=pio_def_var (tape(t)%File,'bdate',PIO_INT,tape(t)%bdateid) str = 'base date (YYYYMMDD)' ierr=pio_put_att (tape(t)%File, tape(t)%bdateid, 'long_name', trim(str)) + end if #endif ierr=pio_def_var (tape(t)%File,'nbsec',PIO_INT,tape(t)%nbsecid) str = 'seconds of base date' @@ -4533,9 +4540,11 @@ subroutine h_define (t, restart) #if ( defined BFB_CAM_SCAM_IOP ) + if (write_camiop) then ierr=pio_def_var (tape(t)%File,'tsec ',pio_int,(/timdim/), tape(t)%tsecid) str = 'current seconds of current date needed for scam' ierr=pio_put_att (tape(t)%File, tape(t)%tsecid, 'long_name', trim(str)) + end if #endif ierr=pio_def_var (tape(t)%File,'nsteph ',pio_int,(/timdim/),tape(t)%nstephid) str = 'current timestep' @@ -4796,9 +4805,11 @@ subroutine h_define (t, restart) deallocate(latvar) end if + if (write_camiop) then dtime = get_step_size() ierr = pio_put_var(tape(t)%File, tape(t)%mdtid, (/dtime/)) call cam_pio_handle_error(ierr, 'h_define: cannot put mdt') + end if ! ! Model date info ! @@ -4810,8 +4821,10 @@ subroutine h_define (t, restart) ierr = pio_put_var(tape(t)%File, tape(t)%nbdateid, (/nbdate/)) call cam_pio_handle_error(ierr, 'h_define: cannot put nbdate') #if ( defined BFB_CAM_SCAM_IOP ) + if (write_camiop) then ierr = pio_put_var(tape(t)%File, tape(t)%bdateid, (/nbdate/)) call cam_pio_handle_error(ierr, 'h_define: cannot put bdate') + end if #endif ierr = pio_put_var(tape(t)%File, tape(t)%nbsecid, (/nbsec/)) call cam_pio_handle_error(ierr, 'h_define: cannot put nbsec') @@ -5562,9 +5575,11 @@ subroutine wshist (rgnht_in) ierr = pio_put_var (tape(t)%File, tape(t)%datesecid,(/start/),(/count1/),(/ncsec/)) #if ( defined BFB_CAM_SCAM_IOP ) + if (write_camiop) then dtime = get_step_size() tsec=dtime*nstep ierr = pio_put_var (tape(t)%File, tape(t)%tsecid,(/start/),(/count1/),(/tsec/)) + end if #endif ierr = pio_put_var (tape(t)%File, tape(t)%nstephid,(/start/),(/count1/),(/nstep/)) time = ndcur + nscur/86400._r8 diff --git a/src/control/history_defaults.F90 b/src/control/history_defaults.F90 deleted file mode 100644 index 0975f56a91..0000000000 --- a/src/control/history_defaults.F90 +++ /dev/null @@ -1,155 +0,0 @@ -module history_defaults -!----------------------------------------------------------------------- -! -! Purpose: contains calls to setup default history stuff that has not found -! a proper home yet. Shouldn't really exist. -! -! Public functions/subroutines: -! bldfld -! -! Author: B.A. Boville from code in cam_history.F90 -!----------------------------------------------------------------------- - use constituents, only: pcnst, cnst_name - - use cam_history, only: addfld, add_default, horiz_only - implicit none - - PRIVATE - - public :: bldfld - -#if ( defined BFB_CAM_SCAM_IOP ) - public :: initialize_iop_history -#endif - -CONTAINS - - -!####################################################################### - subroutine bldfld () -! -!----------------------------------------------------------------------- -! -! Purpose: -! -! Build Master Field List of all possible fields in a history file. Each field has -! associated with it a "long_name" netcdf attribute that describes what the field is, -! and a "units" attribute. -! -! Method: Call a subroutine to add each field -! -! Author: CCM Core Group -! -!----------------------------------------------------------------------- -! -! Local workspace -! - integer m ! Index - character(len=100) dyngrid - - ! Currently SE is the only supported dycore for REPLAY - dyngrid = 'GLL' - -!jt -!jt Maybe add this to scam specific initialization -!jt - -#if ( defined BFB_CAM_SCAM_IOP ) - call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=dyngrid) - call add_default ('CLAT1&IC',0,'I') - call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname=dyngrid) - call add_default ('CLON1&IC',0,'I') - call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname=dyngrid) - call add_default ('PHI&IC',0, 'I') - call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname=dyngrid) - call add_default ('LAM&IC',0, 'I') -#endif - - call addfld ('DQP', (/ 'lev' /), 'A', 'kg/kg/s','Specific humidity tendency due to precipitation', & - gridname='physgrid') - - end subroutine bldfld - -!####################################################################### -#if ( defined BFB_CAM_SCAM_IOP ) - subroutine initialize_iop_history() -! -! !DESCRIPTION: -! !USES: -!jt use iop - use phys_control, only: phys_getopts -! !ARGUMENTS: - implicit none -! -! !CALLED FROM: -! -! !REVISION HISTORY: -! -!EOP -! -! !LOCAL VARIABLES: - integer m - character(len=100) dyngrid - - ! Currently SE is the only supported dycore for REPLAY - dyngrid = 'GLL' -!jt dyngrid = 'gauss_grid' - !----------------------------------------------------------------------- - call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname=trim(dyngrid)) - call add_default ('CLAT',2,' ') - call addfld ('q', (/ 'lev' /), 'A', 'kg/kg', 'Q for scam',gridname=trim(dyngrid)) - call add_default ('q',2, ' ') - call addfld ('u', (/ 'lev' /), 'A', 'm/s', 'U for scam',gridname=trim(dyngrid)) - call add_default ('u',2,' ') - call addfld ('v', (/ 'lev' /), 'A', 'm/s', 'V for scam',gridname=trim(dyngrid)) - call add_default ('v',2,' ') - call addfld ('t', (/ 'lev' /), 'A', 'K', 'Temperature for scam',gridname=trim(dyngrid)) - call add_default ('t',2,' ') - call addfld ('Tg', horiz_only, 'A', 'K', 'Surface temperature (radiative) for scam',gridname='physgrid') - call add_default ('Tg',2,' ') - call addfld ('Ps', horiz_only, 'A', 'Pa', 'Ps for scam',gridname=trim(dyngrid)) - call add_default ('Ps',2,' ') - call addfld ('divT3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for T',gridname=trim(dyngrid)) - call add_default ('divT3d',2,' ') - call addfld ('divU3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for U',gridname=trim(dyngrid)) - call add_default ('divU3d',2,' ') - call addfld ('divV3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for V',gridname=trim(dyngrid)) - call add_default ('divV3d',2,' ') - call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) - call add_default ('fixmas',2,' ') - call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) - call add_default ('beta',2,' ') - call addfld ('heat_glob',horiz_only, 'A', 'K/s', 'Global mean total energy difference') - call add_default ('heat_glob',2,' ') - - do m=1,pcnst - call addfld (trim(cnst_name(m))//'_dten', (/ 'lev' /), 'A', 'kg/kg', & - trim(cnst_name(m))//' IOP Dynamics Residual for '//trim(cnst_name(m)),gridname=trim(dyngrid)) - call add_default (trim(cnst_name(m))//'_dten',2,' ') -!!$ call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & -!!$ gridname=trim(dyngrid)) -!!$ call add_default (trim(cnst_name(m))//'_alph',2,' ') -!!$ call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & -!!$ gridname=trim(dyngrid)) -!!$ call add_default (trim(cnst_name(m))//'_dqfx',2,' ') - end do - call addfld ('shflx', horiz_only, 'A', 'W/m2', 'Surface sensible heat flux for scam',gridname='physgrid') - call add_default ('shflx',2,' ') - call addfld ('lhflx', horiz_only, 'A', 'W/m2', 'Surface latent heat flux for scam',gridname='physgrid') - call add_default ('lhflx',2,' ') - call addfld ('trefht', horiz_only, 'A', 'K', 'Reference height temperature',gridname='physgrid') - call add_default ('trefht',2,' ') - call addfld ('Tsair', horiz_only, 'A', 'K', 'Reference height temperature for scam',gridname='physgrid') - call add_default ('Tsair',2,' ') - call addfld ('phis', horiz_only, 'I', 'm2/s2','Surface geopotential for scam',gridname='physgrid') - call add_default ('phis',2,' ') - call addfld ('Prec', horiz_only, 'A', 'm/s', 'Total (convective and large-scale) precipitation rate for scam', & - gridname='physgrid') - call add_default ('Prec',2,' ') - call addfld ('omega', (/ 'lev' /), 'A', 'Pa/s', 'Vertical velocity (pressure)',gridname='physgrid') - call add_default ('omega',2,' ') - - end subroutine initialize_iop_history -#endif - -end module history_defaults diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index af40cdba9a..ada6460f69 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -1,36 +1,39 @@ module history_scam -!----------------------------------------------------------------------- -! +!----------------------------------------------------------------------- +! ! Purpose: SCAM specific history code. ! ! Public functions/subroutines: ! bldfld, h_default -! +! ! Author: anonymous from code in cam_history.F90 !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: addfld, add_default, horiz_only implicit none PRIVATE public :: scm_intht + public :: initialize_iop_history !####################################################################### CONTAINS subroutine scm_intht() -!----------------------------------------------------------------------- -! -! Purpose: +!----------------------------------------------------------------------- +! +! Purpose: ! ! add master list fields to scm -! +! ! Method: Call a subroutine to add each field -! +! ! Author: CCM Core Group -! +! !----------------------------------------------------------------------- - use cam_history, only: addfld, add_default, horiz_only + use dycore, only: dycore_is + use cam_history, only: write_camiop !----------------------------------------------------------------------- ! !----------------------------------------------------------------------- @@ -38,69 +41,182 @@ subroutine scm_intht() ! integer m,j ! Indices real(r8) dummy + character(len=100) dyngrid + + if (dycore_is('SE')) then + ! for camiop mode use the GLL grid otherwise use physics grids for SCM mode output + if (write_camiop) then + dyngrid = 'GLL' + else + dyngrid = 'physgrid' + end if + else if (dycore_is('EUL')) then + dyngrid = 'gauss_grid' + else + dyngrid = 'unknown' + end if ! ! Call addfld to add each field to the Master Field List. ! - call addfld ('TDIFF', (/ 'lev' /), 'A', 'K','difference from observed temp', gridname='physgrid') - call addfld ('UDIFF', (/ 'lev' /), 'A', 'K','difference from observed u wind', gridname='physgrid') - call addfld ('VDIFF', (/ 'lev' /), 'A', 'K','difference from observed v wind', gridname='physgrid') + call addfld ('TDIFF', (/ 'lev' /), 'A', 'K','difference from observed temp', gridname=trim(dyngrid)) + call addfld ('UDIFF', (/ 'lev' /), 'A', 'K','difference from observed u wind', gridname=trim(dyngrid)) + call addfld ('VDIFF', (/ 'lev' /), 'A', 'K','difference from observed v wind', gridname=trim(dyngrid)) call addfld ('TOBS', (/ 'lev' /), 'A', 'K','observed temp') - call addfld ('QDIFF', (/ 'lev' /), 'A', 'kg/kg','difference from observed water', gridname='physgrid') + call addfld ('QDIFF', (/ 'lev' /), 'A', 'kg/kg','difference from observed water', gridname=trim(dyngrid)) call addfld ('QOBS', (/ 'lev' /), 'A', 'kg/kg','observed water', gridname='physgrid') call addfld ('PRECOBS', (/ 'lev' /), 'A', 'mm/day','Total (convective and large-scale) precipitation rate', & gridname='physgrid') call addfld ('DIVQ', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horizontal)', gridname='physgrid') - call addfld ('DIVQ3D', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horiz/vert combined)', gridname='physgrid') + call addfld ('DIVQ3D', (/ 'lev' /), 'A', 'kg/kg/s','Q advection tendency (horiz/vert combined)', gridname=trim(dyngrid)) call addfld ('DIVV', (/ 'lev' /), 'A', 'm/s2','V advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVU', (/ 'lev' /), 'A', 'm/s2','U advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVT', (/ 'lev' /), 'A', 'K/s','T advection tendency (horizontal)', gridname='physgrid') - call addfld ('DIVT3D', (/ 'lev' /), 'A', 'K/s','T advection tendency (horiz/vert combined)', gridname='physgrid') - call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname='physgrid') - call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname='physgrid') + call addfld ('DIVT3D', (/ 'lev' /), 'A', 'K/s','T advection tendency (horiz/vert combined)', gridname=trim(dyngrid)) + call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname=trim(dyngrid)) + call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname=trim(dyngrid)) call addfld ('SHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface sensible heat flux', gridname='physgrid') call addfld ('LHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface latent heat flux', gridname='physgrid') - call addfld ('TRELAX', (/ 'lev' /), 'A', 'K','t relaxation amount', gridname='physgrid') - call addfld ('QRELAX', (/ 'lev' /), 'A', 'kg/kg','q relaxation amount', gridname='physgrid') - call addfld ('TAURELAX', (/ 'lev' /), 'A', 'seconds','relaxation time constant', gridname='physgrid') + call addfld ('TRELAX', (/ 'lev' /), 'A', 'K','t relaxation amount', gridname=trim(dyngrid)) + call addfld ('QRELAX', (/ 'lev' /), 'A', 'kg/kg','q relaxation amount', gridname=trim(dyngrid)) + call addfld ('TAURELAX', (/ 'lev' /), 'A', 'seconds','relaxation time constant', gridname=trim(dyngrid)) call add_default ('TDIFF', 1, ' ') call add_default ('QDIFF', 1, ' ') ! Vertical advective forcing of 'T,u,v,qv,ql,qi,nl,ni' in forecast.F90 - call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname='physgrid' ) - call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname='physgrid' ) - call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname='physgrid' ) - call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname='physgrid' ) - call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname='physgrid' ) - call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname='physgrid' ) - call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname='physgrid' ) - call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname='physgrid' ) + call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname=trim(dyngrid) ) + call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname=trim(dyngrid) ) ! call addfld ('T3D_ADV_SLT', 'K/s' , pver, 'I', 'T 3d slt advective forcing', gridname='physgrid') ! call addfld ('U3D_ADV_SLT', 'm/s^2' , pver, 'I', 'U 3d slt advective forcing', gridname='physgrid') ! call addfld ('V3D_ADV_SLT', 'm/s^2' , pver, 'I', 'V 3d slt advective forcing', gridname='physgrid') - call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='physgrid' ) - call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='physgrid' ) - call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='physgrid' ) - call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname='physgrid' ) - call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname='physgrid' ) - call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname='physgrid' ) - call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname='physgrid' ) - call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname='physgrid' ) - - call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname='physgrid' ) - call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname='physgrid' ) - call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname='physgrid' ) - call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname='physgrid' ) - call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname='physgrid' ) - call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname='physgrid' ) - call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname='physgrid' ) - call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname='physgrid' ) + call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname=trim(dyngrid) ) + + call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname=trim(dyngrid) ) + call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname=trim(dyngrid) ) end subroutine scm_intht +!####################################################################### + subroutine initialize_iop_history() +! +! !DESCRIPTION: +! !USES: + use constituents, only: pcnst, cnst_name + use dycore, only: dycore_is + use phys_control, only: phys_getopts +! !ARGUMENTS: + implicit none +! +! !CALLED FROM: +! +! !REVISION HISTORY: +! +!EOP +! +! !LOCAL VARIABLES: + integer m + character(len=100) dyngrid + + if (dycore_is('SE')) then + dyngrid = 'GLL' + else if (dycore_is('EUL')) then + dyngrid = 'gauss_grid' + else if (dycore_is('EUL')) then + dyngrid = 'unknown' + end if + +!----------------------------------------------------------------------- + if (trim(dyngrid) == 'gauss_grid') then + call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLAT1&IC',0,'I') + call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLON1&IC',0,'I') + call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('PHI&IC',0, 'I') + call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname=trim(dyngrid)) + call add_default ('LAM&IC',0, 'I') + + call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLAT',2,' ') + + call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) + call add_default ('fixmas',2,' ') + call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) + call add_default ('beta',2,' ') + end if + + call addfld ('q', (/ 'lev' /), 'A', 'kg/kg', 'Q for scam',gridname=trim(dyngrid)) + call add_default ('q',2, ' ') + call addfld ('u', (/ 'lev' /), 'A', 'm/s', 'U for scam',gridname=trim(dyngrid)) + call add_default ('u',2,' ') + call addfld ('v', (/ 'lev' /), 'A', 'm/s', 'V for scam',gridname=trim(dyngrid)) + call add_default ('v',2,' ') + call addfld ('t', (/ 'lev' /), 'A', 'K', 'Temperature for scam',gridname=trim(dyngrid)) + call add_default ('t',2,' ') + call addfld ('Tg', horiz_only, 'A', 'K', 'Surface temperature (radiative) for scam',gridname='physgrid') + call add_default ('Tg',2,' ') + call addfld ('Ps', horiz_only, 'A', 'Pa', 'Ps for scam',gridname=trim(dyngrid)) + call add_default ('Ps',2,' ') + call addfld ('divT3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for T',gridname=trim(dyngrid)) + call add_default ('divT3d',2,' ') + call addfld ('divU3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for U',gridname=trim(dyngrid)) + call add_default ('divU3d',2,' ') + call addfld ('divV3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for V',gridname=trim(dyngrid)) + call add_default ('divV3d',2,' ') + call addfld ('heat_glob',horiz_only, 'A', 'K/s', 'Global mean total energy difference') + call add_default ('heat_glob',2,' ') + do m=1,pcnst + call addfld (trim(cnst_name(m))//'_dten', (/ 'lev' /), 'A', 'kg/kg', & + trim(cnst_name(m))//' IOP Dynamics Residual for '//trim(cnst_name(m)),gridname=trim(dyngrid)) + call add_default (trim(cnst_name(m))//'_dten',2,' ') + if (trim(dyngrid) == 'gauss_grid') then + call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & + gridname=trim(dyngrid)) + call add_default (trim(cnst_name(m))//'_alph',2,' ') + call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & + gridname=trim(dyngrid)) + call add_default (trim(cnst_name(m))//'_dqfx',2,' ') + end if + end do + call addfld ('shflx', horiz_only, 'A', 'W/m2', 'Surface sensible heat flux for scam',gridname='physgrid') + call add_default ('shflx',2,' ') + call addfld ('lhflx', horiz_only, 'A', 'W/m2', 'Surface latent heat flux for scam',gridname='physgrid') + call add_default ('lhflx',2,' ') + call addfld ('trefht', horiz_only, 'A', 'K', 'Reference height temperature',gridname='physgrid') + call add_default ('trefht',2,' ') + call addfld ('Tsair', horiz_only, 'A', 'K', 'Reference height temperature for scam',gridname='physgrid') + call add_default ('Tsair',2,' ') + call addfld ('phis', horiz_only, 'I', 'm2/s2','Surface geopotential for scam',gridname='physgrid') + call add_default ('phis',2,' ') + call addfld ('Prec', horiz_only, 'A', 'm/s', 'Total (convective and large-scale) precipitation rate for scam', & + gridname='physgrid') + call add_default ('Prec',2,' ') + call addfld ('omega', (/ 'lev' /), 'A', 'Pa/s', 'Vertical velocity (pressure)',gridname='physgrid') + call add_default ('omega',2,' ') + + end subroutine initialize_iop_history !####################################################################### end module history_scam diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90 index 8ce8f1e998..ce890d1876 100644 --- a/src/control/ncdio_atm.F90 +++ b/src/control/ncdio_atm.F90 @@ -139,8 +139,8 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & else vargridname='physgrid' end if - ! if running single column mode then we need to use scm grid to read proper column - if (single_column .and. trim(vargridname)=='physgrid') then + + if (single_column .and. vargridname=='physgrid') then vargridname='physgrid_scm' end if @@ -161,14 +161,14 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ! Get the number of columns in the global grid. call cam_grid_dimensions(grid_id, grid_dimlens) ! - ! read netcdf file + ! Read netCDF file ! ! - ! check if field is on file; get netcdf variable id + ! Check if field is on file; get netCDF variable id ! call cam_pio_check_var(ncid, varname, varid, ndims, dimids, dimlens, readvar_tmp) ! - ! if field is on file: + ! If field is on file: ! if (readvar_tmp) then if (debug .and. masterproc) then @@ -177,13 +177,13 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & call shr_sys_flush(iulog) end if ! - ! get array dimension id's and sizes + ! Get array dimension id's and sizes ! arraydimsize(1) = (dim1e - dim1b + 1) arraydimsize(2) = (dim2e - dim2b + 1) do j = 1, 2 if (arraydimsize(j) /= size(field, j)) then - write(errormsg, *) ': mismatch between array bounds and field size for ', & + write(errormsg, *) ': Mismatch between array bounds and field size for ', & trim(varname), ', dimension', j call endrun(trim(subname)//errormsg) end if @@ -194,14 +194,14 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & else if (ndims < 1) then call endrun(trim(subname)//': too few dimensions for '//trim(varname)) else - ! check that the number of columns in the file matches the number of + ! Check that the number of columns in the file matches the number of ! columns in the grid object. if (dimlens(1) /= grid_dimlens(1) .and. .not. single_column) then readvar = .false. return end if - ! check to make sure that the second dimension is time + ! Check to make sure that the second dimension is time if (ndims == 2) then ierr = pio_inq_dimname(ncid, dimids(2), tmpname) if (trim(tmpname) /= 'time') then @@ -227,7 +227,7 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & if (present(fillvalue)) then ierr = cam_pio_inq_var_fill(ncid, varid, fillvalue) end if - + if (masterproc) write(iulog,*) subname//': read field '//trim(varname) end if ! end of readvar_tmp @@ -239,20 +239,20 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & end subroutine infld_real_1d_2d !----------------------------------------------------------------------- - !bop + !BOP ! - ! !iroutine: infld_real_2d_2d + ! !IROUTINE: infld_real_2d_2d ! - ! !interface: + ! !INTERFACE: subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & dim1b, dim1e, dim2b, dim2e, field, readvar, gridname, timelevel, & fillvalue) ! - ! !description: - ! netcdf i/o of initial real field from netcdf file - ! read a 2-d field (or slice) into a 2-d variable + ! !DESCRIPTION: + ! Netcdf I/O of initial real field from netCDF file + ! Read a 2-D field (or slice) into a 2-D variable ! - ! !uses + ! !USES ! use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel @@ -324,6 +324,7 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & call infld(varname, ncid, dimname1, dim1b, dim1e, dim2b, dim2e, & field, readvar, gridname, timelevel) else + ! ! Error conditions ! @@ -332,10 +333,11 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & else vargridname='physgrid' end if - ! if running single column mode then we need to use scm grid to read proper column - if (single_column .and. trim(vargridname)=='physgrid') then - vargridname='physgrid_scm' + + if (single_column .and. vargridname=='physgrid') then + vargridname='physgrid_scm' end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then @@ -555,10 +557,12 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & else vargridname='physgrid' end if + ! if running single column mode then we need to use scm grid to read proper column - if (single_column .and. trim(vargridname)=='physgrid') then - vargridname='physgrid_scm' + if (single_column .and. vargridname=='physgrid') then + vargridname='physgrid_scm' end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then @@ -762,10 +766,12 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, & else vargridname='physgrid' end if + ! if running single column mode then we need to use scm grid to read proper column - if (single_column .and. trim(vargridname)=='physgrid') then - vargridname='physgrid_scm' + if (single_column .and. vargridname=='physgrid') then + vargridname='physgrid_scm' end if + grid_id = cam_grid_id(trim(vargridname)) if (.not. cam_grid_check(grid_id)) then if(masterproc) then diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index 2ae0c18b04..c2ca4391a8 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -1,4 +1,3 @@ - module scamMod !---------------------------------------------------------------------- ! @@ -15,7 +14,7 @@ module scamMod ! this module provide flexibility to affect the forecast by overriding ! parameterization prognosed tendencies with observed tendencies ! of a particular field program recorded on the IOP file. - ! + ! ! Public functions/subroutines: ! scam_readnl !----------------------------------------------------------------------- @@ -23,17 +22,15 @@ module scamMod use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc,npes use pmgrid, only: plon, plat, plev, plevp -use constituents, only: readtrace, cnst_get_ind, pcnst, cnst_name +use constituents, only: cnst_get_ind, pcnst, cnst_name use netcdf, only: NF90_NOERR,NF90_CLOSE,NF90_GET_VAR,NF90_INQUIRE_DIMENSION, & NF90_INQ_DIMID, NF90_INQ_VARID, NF90_NOWRITE, NF90_OPEN, & NF90_GET_ATT,NF90_GLOBAL,NF90_INQUIRE_ATTRIBUTE, & NF90_INQUIRE_VARIABLE, NF90_MAX_VAR_DIMS, nf90_get_var use shr_scam_mod, only: shr_scam_getCloseLatLon -use dycore, only: dycore_is use cam_logfile, only: iulog use cam_abortutils, only: endrun -use time_manager, only: get_curr_date, get_curr_calday,& - get_nstep,is_first_step,get_start_date,timemgr_time_inc +use time_manager, only: get_curr_date, get_nstep,is_first_step,get_start_date,timemgr_time_inc implicit none @@ -41,7 +38,7 @@ module scamMod ! PUBLIC INTERFACES: -public :: scam_readnl ! read SCAM namelist options +public :: scam_readnl ! read SCAM namelist options public :: readiopdata ! read iop boundary data public :: setiopupdate ! find index in iopboundary data for current time public :: plevs0 ! find index in iopboundary data for current time @@ -53,6 +50,10 @@ module scamMod real(r8), public :: pressure_levels(plev) real(r8), public :: scmlat ! input namelist latitude for scam real(r8), public :: scmlon ! input namelist longitude for scam +real(r8), public :: closeioplat ! closest iop latitude for scam +real(r8), public :: closeioplon ! closest iop longitude for scam +integer, public :: closeioplatidx ! file array index of closest iop latitude for scam +integer, public :: closeioplonidx ! file array index closest iop longitude for scam integer, parameter :: num_switches = 20 @@ -61,11 +62,11 @@ module scamMod logical, public :: single_column ! Using IOP file or not logical, public :: use_iop ! Using IOP file or not logical, public :: use_pert_init ! perturb initial values -logical, public :: use_pert_frc ! perturb forcing +logical, public :: use_pert_frc ! perturb forcing logical, public :: switch(num_switches) ! Logical flag settings from GUI logical, public :: l_uvphys ! If true, update u/v after TPHYS logical, public :: l_uvadvect ! If true, T, U & V will be passed to SLT -logical, public :: l_conv ! use flux divergence terms for T and q? +logical, public :: l_conv ! use flux divergence terms for T and q? logical, public :: l_divtr ! use flux divergence terms for constituents? logical, public :: l_diag ! do we want available diagnostics? @@ -117,15 +118,15 @@ module scamMod real(r8), public :: qinitobs(plev,pcnst)! initial tracer field real(r8), public :: cldliqobs(plev) ! actual W.V. Mixing ratio real(r8), public :: cldiceobs(plev) ! actual W.V. Mixing ratio -real(r8), public :: numliqobs(plev) ! actual -real(r8), public :: numiceobs(plev) ! actual -real(r8), public :: precobs(1) ! observed precipitation -real(r8), public :: lhflxobs(1) ! observed surface latent heat flux +real(r8), public :: numliqobs(plev) ! actual +real(r8), public :: numiceobs(plev) ! actual +real(r8), public :: precobs(1) ! observed precipitation +real(r8), public :: lhflxobs(1) ! observed surface latent heat flux real(r8), public :: heat_glob_scm(1) ! observed heat total real(r8), public :: shflxobs(1) ! observed surface sensible heat flux real(r8), public :: q1obs(plev) ! observed apparent heat source real(r8), public :: q2obs(plev) ! observed apparent heat sink -real(r8), public :: tdiff(plev) ! model minus observed temp +real(r8), public :: tdiff(plev) ! model minus observed temp real(r8), public :: tground(1) ! ground temperature real(r8), public :: psobs ! observed surface pressure real(r8), public :: tobs(plev) ! observed temperature @@ -166,23 +167,23 @@ module scamMod ! SCAM public data defaults logical, public :: doiopupdate = .false. ! do we need to read next iop timepoint -logical, public :: have_lhflx = .false. ! dataset contains lhflx +logical, public :: have_lhflx = .false. ! dataset contains lhflx logical, public :: have_shflx = .false. ! dataset contains shflx logical, public :: have_heat_glob = .false. ! dataset contains shflx logical, public :: have_tg = .false. ! dataset contains tg logical, public :: have_tsair = .false. ! dataset contains tsair -logical, public :: have_divq = .false. ! dataset contains divq +logical, public :: have_divq = .false. ! dataset contains divq logical, public :: have_divt = .false. ! dataset contains divt -logical, public :: have_divq3d = .false. ! dataset contains divq3d +logical, public :: have_divq3d = .false. ! dataset contains divq3d logical, public :: have_vertdivu = .false. ! dataset contains vertdivu logical, public :: have_vertdivv = .false. ! dataset contains vertdivv logical, public :: have_vertdivt = .false. ! dataset contains vertdivt -logical, public :: have_vertdivq = .false. ! dataset contains vertdivq +logical, public :: have_vertdivq = .false. ! dataset contains vertdivq logical, public :: have_divt3d = .false. ! dataset contains divt3d logical, public :: have_divu3d = .false. ! dataset contains divu3d logical, public :: have_divv3d = .false. ! dataset contains divv3d logical, public :: have_divu = .false. ! dataset contains divu -logical, public :: have_divv = .false. ! dataset contains divv +logical, public :: have_divv = .false. ! dataset contains divv logical, public :: have_omega = .false. ! dataset contains omega logical, public :: have_phis = .false. ! dataset contains phis logical, public :: have_ptend = .false. ! dataset contains ptend @@ -190,10 +191,10 @@ module scamMod logical, public :: have_q = .false. ! dataset contains q logical, public :: have_q1 = .false. ! dataset contains Q1 logical, public :: have_q2 = .false. ! dataset contains Q2 -logical, public :: have_prec = .false. ! dataset contains prec +logical, public :: have_prec = .false. ! dataset contains prec logical, public :: have_t = .false. ! dataset contains t -logical, public :: have_u = .false. ! dataset contains u -logical, public :: have_v = .false. ! dataset contains v +logical, public :: have_u = .false. ! dataset contains u +logical, public :: have_v = .false. ! dataset contains v logical, public :: have_cld = .false. ! dataset contains cld logical, public :: have_cldliq = .false. ! dataset contains cldliq logical, public :: have_cldice = .false. ! dataset contains cldice @@ -204,10 +205,10 @@ module scamMod logical, public :: have_aldif = .false. ! dataset contains aldif logical, public :: have_asdir = .false. ! dataset contains asdir logical, public :: have_asdif = .false. ! dataset contains asdif -logical, public :: use_camiop = .false. ! use cam generated forcing +logical, public :: use_camiop = .false. ! use cam generated forcing logical, public :: use_3dfrc = .false. ! use 3d forcing logical, public :: isrestart = .false. ! If this is a restart step or not - + ! SCAM namelist defaults logical, public :: scm_backfill_iop_w_init = .false. ! Backfill missing IOP data from initial file @@ -244,7 +245,6 @@ module scamMod integer, allocatable, public :: tsec(:) integer, public :: ntime -save bdate !======================================================================= contains @@ -280,30 +280,30 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) scm_cambfb_mode,scm_crm_mode,scm_zadv_uv,scm_zadv_T,scm_zadv_q,& scm_use_obs_T, scm_use_obs_uv, scm_use_obs_qv, scm_use_3dfrc, & scm_relax_linear, scm_relax_tau_top_sec, & - scm_relax_tau_bot_sec, scm_force_latlon, scm_relax_fincl, scm_backfill_iop_w_init + scm_relax_tau_bot_sec, scm_force_latlon, scm_relax_fincl, & + scm_backfill_iop_w_init single_column=single_column_in iopfile = ' ' scm_clubb_iop_name = ' ' scm_relax_fincl(:) = ' ' - if( single_column ) then if( npes.gt.1) call endrun('SCAM_READNL: SCAM doesnt support using more than 1 pe.') - if ( .not. (dycore_is('EUL') .or. dycore_is('SE')) .or. plon /= 1 .or. plat /=1 ) then + if ( .not. (dycore_is('EUL') .or. dycore_is('SE')) .or. plon /= 1 .or. plat /=1 ) then call endrun('SCAM_SETOPTS: must compile model for SCAM mode when namelist parameter single_column is .true.') endif scmlat=scmlat_in scmlon=scmlon_in - + if( scmlat .lt. -90._r8 .or. scmlat .gt. 90._r8 ) then call endrun('SCAM_READNL: SCMLAT must be between -90. and 90. degrees.') elseif( scmlon .lt. 0._r8 .or. scmlon .gt. 360._r8 ) then call endrun('SCAM_READNL: SCMLON must be between 0. and 360. degrees.') end if - + ! Read namelist if (masterproc) then unitn = getunit() @@ -318,11 +318,11 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) close(unitn) call freeunit(unitn) end if - + ! Error checking: - + iopfile = trim(iopfile) - if( iopfile .ne. "" ) then + if( iopfile .ne. "" ) then use_iop = .true. else call endrun('SCAM_READNL: must specify IOP file for single column mode') @@ -335,18 +335,17 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) else use_camiop = .false. endif - + ! If we are not forcing the lat and lon from the namelist use the closest lat and lon that is found in the IOP file. if (.not.scm_force_latlon) then - call shr_scam_GetCloseLatLon( ncid, scmlat, scmlon, ioplat, ioplon, latidx, lonidx ) + call shr_scam_GetCloseLatLon( ncid, scmlat, scmlon, closeioplat, closeioplon, closeioplatidx, closeioplonidx ) write(iulog,*) 'SCAM_READNL: using closest IOP column to lat/lon specified in drv_in' write(iulog,*) ' requested lat,lon =',scmlat,', ',scmlon - write(iulog,*) ' closest IOP lat,lon =',ioplat,', ',ioplon - - scmlat = ioplat - scmlon = ioplon + write(iulog,*) ' closest IOP lat,lon =',closeioplat,', ',closeioplon + scmlat = closeioplat + scmlon = closeioplon end if - + if (masterproc) then write (iulog,*) 'Single Column Model Options: ' write (iulog,*) '=============================' @@ -388,24 +387,19 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) print * end if end if - + end subroutine scam_readnl subroutine readiopdata(hvcoord) -!jt subroutine readiopdata(timelevel) - - !----------------------------------------------------------------------- -! +! ! Open and read netCDF file containing initial IOP conditions -! +! !---------------------------Code history-------------------------------- -! +! ! Written by J. Truesdale August, 1996, revised January, 1998 -! +! !----------------------------------------------------------------------- -!jt use prognostics, only: n3,t3,q3,u3,v3,ps - use ppgrid, only: begchunk, endchunk !jt fix this circular depend use phys_grid, only: clat_p !jt use commap, only: latdeg, clat use hybvcoord_mod, only: hvcoord_t @@ -421,18 +415,15 @@ subroutine readiopdata(hvcoord) #endif character(len=*), parameter :: sub = "read_iop_data" - +! !------------------------------Input Arguments-------------------------- -! -!jt integer, optional, intent(in) :: timelevel +! type (hvcoord_t), intent(in) :: hvcoord - +! !------------------------------Locals----------------------------------- -! -!!$ integer ntimelevel +! integer NCID, status - integer time_dimID, lev_dimID, lev_varID - integer tsec_varID, bdate_varID,varid + integer time_dimID, lev_dimID, lev_varID, varid integer i,j integer nlev integer total_levs @@ -442,12 +433,11 @@ subroutine readiopdata(hvcoord) integer k, m integer icldliq,icldice integer inumliq,inumice,idx - integer closelatidx,closelonidx,latid,lonid,levid,timeid,ncolid,ncol + integer timeid logical have_srf ! value at surface is available - logical fill_ends ! + logical fill_ends ! logical have_cnst(pcnst) - real(r8) closelat,closelon real(r8) dummy real(r8) lat,xlat real(r8) srf(1) ! value at surface @@ -462,26 +452,19 @@ subroutine readiopdata(hvcoord) integer strt4(4),cnt4(4) character(len=16) :: lowername character(len=128) :: units ! Units - integer, allocatable :: tsec(:) nstep = get_nstep() fill_ends= .false. -!!$ if (present(timelevel)) then -!!$ ntimelevel=timelevel -!!$ else -!!$ ntimelevel=n3 -!!$ end if - -! +! ! Open IOP dataset -! +! call handle_ncerr( nf90_open (iopfile, 0, ncid),& 'readiopdata.F90', __LINE__) ! ! if the dataset is a CAM generated dataset set use_camiop to true -! CAM IOP datasets have a global attribute called CAM_GENERATED_IOP +! CAM IOP datasets have a global attribute called CAM_GENERATED_IOP ! if ( nf90_inquire_attribute( ncid, NF90_GLOBAL, 'CAM_GENERATED_FORCING', attnum=i )== NF90_NOERR ) then use_camiop = .true. @@ -490,7 +473,7 @@ subroutine readiopdata(hvcoord) endif !===================================================================== -! +! ! Read time variables @@ -507,28 +490,10 @@ subroutine readiopdata(hvcoord) call handle_ncerr( nf90_inquire_dimension( ncid, time_dimID, len=ntime ),& 'readiopdata.F90', __LINE__) - allocate(tsec(ntime)) - - status = nf90_inq_varid (ncid, 'tsec', tsec_varID ) - call handle_ncerr( nf90_get_var (ncid, tsec_varID, tsec),& - 'readiopdata.F90', __LINE__) - - status = nf90_inq_varid (ncid, 'nbdate', bdate_varID ) - if (status /= NF90_NOERR) then - status = nf90_inq_varid (ncid, 'bdate', bdate_varID ) - if (status /= NF90_NOERR) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for bdate' - status = NF90_CLOSE ( ncid ) - call endrun - end if - end if - call handle_ncerr( nf90_get_var (ncid, bdate_varID, bdate),& - 'readiopdata.F90', __LINE__) - -! +! !====================================================== ! read level data -! +! status = NF90_INQ_DIMID( ncid, 'lev', lev_dimID ) if ( status .ne. nf90_noerr ) then if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable dim ID for lev' @@ -568,45 +533,6 @@ subroutine readiopdata(hvcoord) end do endif - -!!$ call shr_scam_GetCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,closelatidx,closelonidx) -!!$ -!!$ lonid = 0 -!!$ latid = 0 -!!$ levid = 0 -!!$ timeid = 0 -!!$ -!!$ ncolstatus = NF90_INQ_DIMID( ncid, 'ncol', ncolid )==nf90_noerr -!!$ ncoldstatus = NF90_INQ_DIMID( ncid, 'ncol_d', ncoldid ) -!!$ if ( NF90_INQ_DIMID( ncid, 'lat', latid )==nf90_noerr .or. NF90_INQ_DIMID( ncid, 'lat_d', latid )==nf90_noerr ) then -!!$ -!!$ call wrap_inq_dimid(ncid, 'lat', latid) -!!$ call wrap_inq_dimid(ncid, 'lon', lonid) -!!$ call wrap_inq_dimid(ncid, 'lev', levid) -!!$ call wrap_inq_dimid(ncid, 'time', timeid) -!!$ -!!$ strt4(1) = closelonidx -!!$ strt4(2) = closelatidx -!!$ strt4(3) = iopTimeIdx -!!$ strt4(4) = 1 -!!$ cnt4(1) = 1 -!!$ cnt4(2) = 1 -!!$ cnt4(3) = 1 -!!$ cnt4(4) = 1 -!!$ else if ( NF90_INQ_DIMID( ncid, 'ncol', ncolid )==nf90_noerr .or. NF90_INQ_DIMID( ncid, 'ncol_d', ncoldid )==nf90_noerr ) then -!!$ call wrap_inq_dimid(ncid, 'ncol', ncolid) -!!$ call wrap_inq_dimid(ncid, 'lev', levid) -!!$ call wrap_inq_dimid(ncid, 'time', timeid) -!!$ -!!$ strt4(1) = closelonidx -!!$ strt4(2) = iopTimeIdx -!!$ strt4(3) = 1 -!!$ strt4(4) = 1 -!!$ cnt4(1) = 1 -!!$ cnt4(2) = 1 -!!$ cnt4(3) = 1 -!!$ cnt4(4) = 1 -!!$ end if status = nf90_inq_varid( ncid, 'Ps', varid ) if ( status .ne. nf90_noerr ) then have_ps = .false. @@ -625,8 +551,8 @@ subroutine readiopdata(hvcoord) ! If the IOP dataset has hyam,hybm,etc it is assumed to be a hybrid level -! dataset. - +! dataset + status = nf90_inq_varid( ncid, 'hyam', varid ) if ( status == nf90_noerr .and. have_ps) then call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -720,13 +646,10 @@ subroutine readiopdata(hvcoord) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,tsair) have_tsair = .true. endif - ! ! read in Tobs For cam generated iop readin small t to avoid confusion ! with capital T defined in cam ! - -!jt tobs(:)= t3(1,:,1,ntimelevel) tobs(:)= 0._r8 if ( use_camiop ) then @@ -747,9 +670,9 @@ subroutine readiopdata(hvcoord) else if (masterproc) write(iulog,*) sub//':Using value from Analysis Dataset' endif -! +! ! set T3 to Tobs on first time step -! +! else have_t = .true. endif @@ -782,13 +705,7 @@ subroutine readiopdata(hvcoord) have_srf = .true. endif -!jt if (is_first_step()) then -!jt qinitobs(:,:)=q3(1,:,:,1,ntimelevel) -!jt end if -!!$ -!jt qobs(:)= q3(1,:,1,1,ntimelevel) qobs(:)= 0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, qobs, status ) @@ -813,7 +730,7 @@ subroutine readiopdata(hvcoord) else have_cld = .true. endif - + clwpobs = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'clwp', .false., & dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, clwpobs, status ) @@ -825,7 +742,7 @@ subroutine readiopdata(hvcoord) ! ! read divq (horizontal advection) -! +! status = nf90_inq_varid( ncid, 'divqsrf', varid ) if ( status .ne. nf90_noerr ) then have_srf = .false. @@ -877,15 +794,12 @@ subroutine readiopdata(hvcoord) status = nf90_get_var(ncid, varid, srf(1), strt4) have_srf = .true. endif - - ! ! add calls to get dynamics tendencies for all prognostic consts ! divq3d=0._r8 do m = 1, pcnst - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dten', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq3d(:,m), status ) @@ -896,7 +810,7 @@ subroutine readiopdata(hvcoord) if (m==1) have_divq3d = .true. have_cnst(m) = .true. endif - + coldata = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dqfx', & have_srf, srf(1), fill_ends, scm_crm_mode, & @@ -912,11 +826,9 @@ subroutine readiopdata(hvcoord) have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tmpdata, status ) if ( status .ne. nf90_noerr ) then -! have_cnst(m) = .false. alphacam(m)=0._r8 else alphacam(m)=tmpdata(1) -! have_cnst(m) = .true. endif end do @@ -933,9 +845,6 @@ subroutine readiopdata(hvcoord) have_numliq = .false. else have_numliq = .true. -!!$ do i=1, PLEV -!!$ q3(1,i,inumliq,1,ntimelevel)=numliqobs(i) -!!$ end do endif else have_numliq = .false. @@ -953,9 +862,6 @@ subroutine readiopdata(hvcoord) have_cldliq = .false. else have_cldliq = .true. -!!$ do i=1, PLEV -!!$ q3(1,i,icldliq,1,ntimelevel)=cldliqobs(i) -!!$ end do endif else have_cldliq = .false. @@ -971,9 +877,6 @@ subroutine readiopdata(hvcoord) have_cldice = .false. else have_cldice = .true. -!!$ do i=1, PLEV -!!$ q3(1,i,icldice,1,ntimelevel)=cldiceobs(i) -!!$ end do endif else have_cldice = .false. @@ -990,9 +893,6 @@ subroutine readiopdata(hvcoord) have_numice = .false. else have_numice = .true. -!!$ do i=1, PLEV -!!$ q3(1,i,inumice,1,ntimelevel)=numiceobs(i) -!!$ end do endif else have_numice = .false. @@ -1000,7 +900,7 @@ subroutine readiopdata(hvcoord) ! ! read divu (optional field) -! +! status = nf90_inq_varid( ncid, 'divusrf', varid ) if ( status .ne. nf90_noerr ) then have_srf = .false. @@ -1021,7 +921,7 @@ subroutine readiopdata(hvcoord) endif ! ! read divv (optional field) -! +! status = nf90_inq_varid( ncid, 'divvsrf', varid ) if ( status .ne. nf90_noerr ) then have_srf = .false. @@ -1042,7 +942,7 @@ subroutine readiopdata(hvcoord) endif ! ! read divt (optional field) -! +! status = nf90_inq_varid( ncid, 'divtsrf', varid ) if ( status .ne. nf90_noerr ) then have_srf = .false. @@ -1053,7 +953,6 @@ subroutine readiopdata(hvcoord) endif divt=0._r8 - call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'divT', have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt, status ) @@ -1074,9 +973,8 @@ subroutine readiopdata(hvcoord) status = nf90_get_var(ncid, varid, srf(1), strt4) have_srf = .true. endif - - vertdivt=0._r8 + vertdivt=0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivTx', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) @@ -1198,9 +1096,6 @@ subroutine readiopdata(hvcoord) have_u = .false. else have_u = .true. -!!$ do i=1, PLEV -!!$ u3(1,i,1,ntimelevel) = uobs(i) ! set u to uobs at first time step -!!$ end do endif status = nf90_inq_varid( ncid, 'vsrf', varid ) @@ -1221,9 +1116,6 @@ subroutine readiopdata(hvcoord) have_v = .false. else have_v = .true. -!!$ do i=1, PLEV -!!$ v3(1,i,1,ntimelevel) = vobs(i) ! set u to uobs at first time step -!!$ end do endif call shr_sys_flush( iulog ) @@ -1258,7 +1150,7 @@ subroutine readiopdata(hvcoord) have_q2 = .true. endif -! Test for BOTH 'lhflx' and 'lh' without overwriting 'have_lhflx'. +! Test for BOTH 'lhflx' and 'lh' without overwriting 'have_lhflx'. ! Analagous changes made for the surface heat flux status = nf90_inq_varid( ncid, 'lhflx', varid ) @@ -1294,8 +1186,8 @@ subroutine readiopdata(hvcoord) endif call shr_sys_flush( iulog ) - ! If REPLAY is used, then need to read in the global - ! energy fixer + ! If REPLAY is used, then need to read in the global + ! energy fixer status = nf90_inq_varid( ncid, 'heat_glob', varid ) if (status .ne. nf90_noerr) then have_heat_glob = .false. @@ -1335,7 +1227,7 @@ subroutine readiopdata(hvcoord) endif call shr_sys_flush( iulog ) - + !!$ status = nf90_inq_varid( ncid, 'CLAT', varid ) !!$ if ( status == nf90_noerr ) then !!$ call wrap_get_vara_realx (ncid,varid,strt4,cnt4,clat) @@ -1349,7 +1241,7 @@ subroutine readiopdata(hvcoord) else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) status = nf90_get_var(ncid, varid, srf(1), strt4) - betacam=srf(1) + betacam=srf(1) endif status = nf90_inq_varid( ncid, 'fixmas', varid ) @@ -1366,7 +1258,7 @@ subroutine readiopdata(hvcoord) status = nf90_close( ncid ) call shr_sys_flush( iulog ) - deallocate(dplevs,tsec) + deallocate(dplevs) return end subroutine readiopdata @@ -1374,13 +1266,13 @@ end subroutine readiopdata subroutine setiopupdate !----------------------------------------------------------------------- -! +! ! Open and read netCDF file to extract time information ! !---------------------------Code history-------------------------------- ! ! Written by John Truesdale August, 1996 -! +! !----------------------------------------------------------------------- implicit none #if ( defined RS6000 ) @@ -1397,102 +1289,22 @@ subroutine setiopupdate integer next_date, next_sec integer :: ncsec,ncdate ! current time of day,date integer :: yr, mon, day ! year, month, and day component - integer :: start_ymd,start_tod + integer :: start_ymd,start_tod,dt !------------------------------------------------------------------------------ - if ( is_first_step() ) then -! -! Open IOP dataset -! - STATUS = NF90_OPEN( iopfile, NF90_NOWRITE, NCID ) -! -! Read time (tsec) variable -! - STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:', & - 'Cant get variable ID for tsec' - - STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR ) then - STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:Cant get variable ID for bdate' - endif - - STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then - STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then - write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' - STATUS = NF90_CLOSE ( NCID ) - return - end if - end if - - if ( STATUS .NE. NF90_NOERR .and. masterproc) write(iulog,*) & - sub//':ERROR - setiopupdate.F:Cant get variable dim ID for time' - - STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) - if ( STATUS .NE. NF90_NOERR ) then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get time dimlen' - endif - - STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) - if ( STATUS .NE. NF90_NOERR )then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable tsec' - endif - STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) - if ( STATUS .NE. NF90_NOERR )then - if (masterproc) write(iulog,*) sub//':ERROR - setiopupdate.F:Cant get variable bdate' - endif -! Close the netCDF file - STATUS = NF90_CLOSE( NCID ) -! -! determine the last date in the iop dataset -! - call timemgr_time_inc(bdate, 0, last_date, last_sec, inc_s=tsec(ntime)) -! -! set the iop dataset index -! - iopTimeIdx=0 - do i=1,ntime ! set the first ioptimeidx - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(i)) - call get_start_date(yr,mon,day,start_tod) - start_ymd = yr*10000 + mon*100 + day - - if ( start_ymd > next_date .or. (start_ymd == next_date & - .and. start_tod >= next_sec)) then - iopTimeIdx = i - endif - enddo - - call get_curr_date(yr,mon,day,ncsec) - ncdate=yr*10000 + mon*100 + day - - if (iopTimeIdx == 0.or.iopTimeIdx >= ntime) then - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(1)) - if (masterproc) then - write(iulog,*) 'Error::setiopupdate: Current model time does not fall within IOP period' - write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' - write(iulog,*) ' IOP start is ',next_date,' and ',next_sec,' seconds' - write(iulog,*) ' IOP end is ',last_date,' and ',last_sec,' seconds' - end if - call endrun - endif - - doiopupdate = .true. + call get_curr_date(yr,mon,day,ncsec) + ncdate=yr*10000 + mon*100 + day !------------------------------------------------------------------------------ ! Check if iop data needs to be updated and set doiopupdate accordingly !------------------------------------------------------------------------------ - else ! endstep > 1 - call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) + if ( is_first_step() ) then + doiopupdate = .true. - call get_curr_date(yr, mon, day, ncsec) - ncdate = yr*10000 + mon*100 + day + else + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) if ( ncdate > next_date .or. (ncdate == next_date & .and. ncsec >= next_sec)) then iopTimeIdx = iopTimeIdx + 1 @@ -1502,11 +1314,11 @@ subroutine setiopupdate if (masterproc) write(iulog,*) sub//'ncdate=',ncdate,' ncsec=',ncsec if (masterproc) write(iulog,*) sub//'next_date=',next_date,' next_sec=',next_sec if (masterproc) write(iulog,*) sub//':******* do iop update' -#endif +#endif else doiopupdate = .false. end if - endif ! if (endstep == 0 ) + endif ! if (endstep = 1 ) ! ! make sure we're ! not going past end of iop data @@ -1516,7 +1328,7 @@ subroutine setiopupdate if ( .not. scm_backfill_iop_w_init ) then call endrun(sub//':ERROR - setiopupdate.c:Reached the end of the time varient dataset') else - doiopupdate = .false. + doiopupdate = .false. end if endif @@ -1532,16 +1344,16 @@ end subroutine setiopupdate subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) -!----------------------------------------------------------------------- -! -! Purpose: +!----------------------------------------------------------------------- +! +! Purpose: ! Define the pressures of the interfaces and midpoints from the ! coordinate definitions and the surface pressure. -! -! Method: -! +! +! Method: +! ! Author: B. Boville -! +! !----------------------------------------------------------------------- ! ! $Id$ @@ -1586,22 +1398,22 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) end subroutine plevs0 subroutine scmiop_flbc_inti ( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) - !----------------------------------------------------------------------- - ! - ! Purpose: + !----------------------------------------------------------------------- + ! + ! Purpose: ! Get start count for variable - ! - ! Method: - ! + ! + ! Method: + ! ! Author: - ! + ! !----------------------------------------------------------------------- ! ! $Id$ ! $Author$ ! !----------------------------------------------------------------------- - + implicit none real(r8), intent(out) :: co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr @@ -1617,22 +1429,22 @@ end subroutine scmiop_flbc_inti subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start ,count) - !----------------------------------------------------------------------- - ! - ! Purpose: + !----------------------------------------------------------------------- + ! + ! Purpose: ! set global lower boundary conditions - ! - ! Method: - ! + ! + ! Method: + ! ! Author: - ! + ! !----------------------------------------------------------------------- ! ! $Id$ ! $Author$ ! !----------------------------------------------------------------------- - + implicit none @@ -1668,9 +1480,9 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , write(iulog,* ) 'ERROR - extractdata.F:Cant get dimension IDs for varid', varid return endif -! -! Initialize the start and count arrays -! +! +! Initialize the start and count arrays +! dims_set = 0 nlev = 1 do i = var_ndims, 1, -1 @@ -1680,7 +1492,7 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , if ( trim(dim_name) .EQ. 'lat' ) then start( i ) = latIdx - count( i ) = 1 ! Extract a single value + count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 usable_var = .true. endif @@ -1708,10 +1520,10 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , usable_var = .true. endif - if ( trim(dim_name) .EQ. 'time' .OR. trim(dim_name) .EQ. 'tsec' ) then + if ( trim(dim_name) .EQ. 'time' .OR. trim(dim_name) .EQ. 'tsec' ) then start( i ) = TimeIdx - count( i ) = 1 ! Extract a single value - dims_set = dims_set + 1 + count( i ) = 1 ! Extract a single value + dims_set = dims_set + 1 usable_var = .true. endif end do @@ -1722,7 +1534,7 @@ end subroutine get_start_count subroutine setiopupdate_init !----------------------------------------------------------------------- -! +! ! Open and read netCDF file to extract time information ! This subroutine should be called at the first SCM time step ! @@ -1730,7 +1542,7 @@ subroutine setiopupdate_init ! ! Written by John Truesdale August, 1996 ! Modified for E3SM by Peter Bogenschutz 2017 - onward -! +! !----------------------------------------------------------------------- implicit none #if ( defined RS6000 ) diff --git a/src/cpl/nuopc/atm_comp_nuopc.F90 b/src/cpl/nuopc/atm_comp_nuopc.F90 index 090b7618a9..8b2ba903d0 100644 --- a/src/cpl/nuopc/atm_comp_nuopc.F90 +++ b/src/cpl/nuopc/atm_comp_nuopc.F90 @@ -2030,10 +2030,6 @@ subroutine cam_set_mesh_for_single_column(scol_lon, scol_lat, mesh, rc) mincornerCoord(2) = scol_lat - .1_r8 ! min lat maxcornerCoord(1) = scol_lon + .1_r8 ! max lon maxcornerCoord(2) = scol_lat + .1_r8 ! max lat -!jt mincornerCoord(1) = scol_lon - fraction(scol_lon) ! min lon -!jt mincornerCoord(2) = scol_lat - fraction(scol_lat) ! min lat -!jt maxcornerCoord(1) = scol_lon + fraction(scol_lon) ! max lon -!jt maxcornerCoord(2) = scol_lat + fraction(scol_lat) ! max lat ! create the ESMF grid lgrid = ESMF_GridCreateNoPeriDimUfrm (maxindex=maxindex, & diff --git a/src/cpl/nuopc/atm_stream_ndep.F90 b/src/cpl/nuopc/atm_stream_ndep.F90 index 0373416f4b..394808a529 100644 --- a/src/cpl/nuopc/atm_stream_ndep.F90 +++ b/src/cpl/nuopc/atm_stream_ndep.F90 @@ -243,8 +243,6 @@ subroutine stream_ndep_interp(cam_out, rc) end if g = 1 - call truncate_precision(dataptr1d_nhx,size(dataptr1d_nhx),12) - call truncate_precision(dataptr1d_noy,size(dataptr1d_noy),12) do c = begchunk,endchunk do i = 1,get_ncols_p(c) cam_out(c)%nhx_nitrogen_flx(i) = dataptr1d_nhx(g) @@ -255,27 +253,4 @@ subroutine stream_ndep_interp(cam_out, rc) end subroutine stream_ndep_interp - !================================================================ - - subroutine truncate_precision(a, n, digits) - ! input/output variables - real(r8), dimension(n), & - & intent(inout) :: a - integer, intent(in) :: digits,n - - ! local variables - real(r8) :: scale(n),atmp(n),scale1(n) - - !----------------------------------------------------------------------- - - where (a == 0._r8) - a=0._r8 - elsewhere - scale=(floor(log10(dabs(a)))+1 - digits) - end where - scale=10**scale - a=scale*dint(a/scale) - end subroutine truncate_precision - - end module atm_stream_ndep diff --git a/src/dynamics/eul/diag_dynvar_ic.F90 b/src/dynamics/eul/diag_dynvar_ic.F90 index c963605fe6..f7e20c3df9 100644 --- a/src/dynamics/eul/diag_dynvar_ic.F90 +++ b/src/dynamics/eul/diag_dynvar_ic.F90 @@ -1,15 +1,15 @@ subroutine diag_dynvar_ic(phis, ps, t3, u3, v3, q3) ! -!----------------------------------------------------------------------- -! +!----------------------------------------------------------------------- +! ! Purpose: record state variables to IC file ! !----------------------------------------------------------------------- ! use shr_kind_mod, only: r8 => shr_kind_r8 use pmgrid - use cam_history , only: outfld, write_inithist + use cam_history , only: outfld, write_inithist, write_camiop use constituents, only: pcnst, cnst_name use commap, only:clat,clon use dyn_grid, only : get_horiz_grid_d @@ -44,16 +44,16 @@ subroutine diag_dynvar_ic(phis, ps, t3, u3, v3, q3) call outfld('T&IC ' , t3 (1,1,lat), plon, lat) call outfld('U&IC ' , u3 (1,1,lat), plon, lat) call outfld('V&IC ' , v3 (1,1,lat), plon, lat) -#if (defined BFB_CAM_SCAM_IOP) - clat_plon(:)=clat(lat) - call outfld('CLAT1&IC ', clat_plon, plon, lat) - call outfld('CLON1&IC ', clon, plon, lat) - call get_horiz_grid_d(plat, clat_d_out=phi) - call get_horiz_grid_d(plon, clon_d_out=lam) - clat_plon(:)=phi(lat) - call outfld('LAM&IC ', lam, plon, lat) - call outfld('PHI&IC ', clat_plon, plon, lat) -#endif + if (write_camiop) then + clat_plon(:)=clat(lat) + call outfld('CLAT1&IC ', clat_plon, plon, lat) + call outfld('CLON1&IC ', clon, plon, lat) + call get_horiz_grid_d(plat, clat_d_out=phi) + call get_horiz_grid_d(plon, clon_d_out=lam) + clat_plon(:)=phi(lat) + call outfld('LAM&IC ', lam, plon, lat) + call outfld('PHI&IC ', clat_plon, plon, lat) + end if do m=1,pcnst call outfld(trim(cnst_name(m))//'&IC', q3(1,1,m,lat), plon, lat) diff --git a/src/dynamics/eul/dp_coupling.F90 b/src/dynamics/eul/dp_coupling.F90 index 0503b33ccc..bc900e2d0e 100644 --- a/src/dynamics/eul/dp_coupling.F90 +++ b/src/dynamics/eul/dp_coupling.F90 @@ -5,7 +5,7 @@ module dp_coupling use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, begchunk, endchunk + use ppgrid, only: pcols, pver use pmgrid, only: plev, beglat, endlat, plon use phys_grid diff --git a/src/dynamics/eul/dyn_comp.F90 b/src/dynamics/eul/dyn_comp.F90 index 2f5b36931d..6b0a6f1af6 100644 --- a/src/dynamics/eul/dyn_comp.F90 +++ b/src/dynamics/eul/dyn_comp.F90 @@ -221,9 +221,6 @@ subroutine dyn_init(dyn_in, dyn_out) use scamMod, only: single_column #if (defined SPMD) use spmd_dyn, only: spmdbuf -#endif -#if (defined BFB_CAM_SCAM_IOP ) - use history_defaults, only: initialize_iop_history #endif use dyn_tests_utils, only: vc_dycore, vc_moist_pressure,string_vc, vc_str_lgth ! Arguments are not used in this dycore, included for compatibility @@ -258,10 +255,6 @@ subroutine dyn_init(dyn_in, dyn_out) call set_phis() if (initial_run) then - -#if (defined BFB_CAM_SCAM_IOP ) - call initialize_iop_history() -#endif call read_inidat() call clean_iodesc_list() end if @@ -404,7 +397,6 @@ subroutine read_inidat() real(r8), allocatable :: tmp2d(:,:) character(len=*), parameter :: sub='read_inidat' - integer ioptop,k !---------------------------------------------------------------------------- fh_ini => initial_file_get_id() @@ -587,15 +579,6 @@ subroutine read_inidat() call setiopupdate() call readiopdata(hvcoord) call iop_update_prognostics(1,t3=t3,u3=u3,v3=v3,q3=q3,ps=ps) -!!$ ! set t3, and q3(n1) values from iop on timestep 0 -!!$ ! Find level where tobs is no longer zero -!!$ ioptop = minloc(tobs(:), 1, BACK=.true.)+1 -!!$ -!!$ ps(:,:,1) = psobs -!!$ t3(1,ioptop:,1,1) = tobs(ioptop:) -!!$ u3(1,ioptop:,1,1) = uobs(ioptop:) -!!$ v3(1,ioptop:,1,1) = vobs(ioptop:) -!!$ q3(1,ioptop:,1,1,1) = qobs(ioptop:) end if end if @@ -617,7 +600,7 @@ subroutine set_phis() ! Local variables type(file_desc_t), pointer :: fh_topo - + integer :: ierr, pio_errtype integer :: lonid, latid integer :: mlon, morec ! lon/lat dimension lengths from topo file @@ -637,7 +620,7 @@ subroutine set_phis() readvar = .false. - if (associated(fh_topo)) then + if (associated(fh_topo)) then call pio_seterrorhandling(fh_topo, PIO_BCAST_ERROR, pio_errtype) @@ -724,11 +707,9 @@ subroutine process_inidat(fieldname, m_cnst, fh) real(r8), pointer, dimension(:,:,:) :: tmp3d_a, tmp3d_b, tmp3d_extend real(r8), pointer, dimension(:,: ) :: tmp2d_a, tmp2d_b -#if ( defined BFB_CAM_SCAM_IOP ) real(r8), allocatable :: ps_sav(:,:) real(r8), allocatable :: u3_sav(:,:,:) real(r8), allocatable :: v3_sav(:,:,:) -#endif #if ( defined SPMD ) integer :: numperlat ! number of values per latitude band diff --git a/src/dynamics/eul/dyn_grid.F90 b/src/dynamics/eul/dyn_grid.F90 index 1b2ecf3646..c9036b54ee 100644 --- a/src/dynamics/eul/dyn_grid.F90 +++ b/src/dynamics/eul/dyn_grid.F90 @@ -19,8 +19,6 @@ module dyn_grid use cam_logfile, only: iulog use hybvcoord_mod, only: hvcoord_t use shr_const_mod, only: SHR_CONST_PI, SHR_CONST_REARTH -use physics_column_type, only: physics_column_t - #if (defined SPMD) use spmd_dyn, only: spmdinit_dyn @@ -52,7 +50,6 @@ module dyn_grid get_horiz_grid_d, &! horizontal grid coordinates get_horiz_grid_dim_d, &! horizontal dimensions of dynamics grid hvcoord, &! vertical coordinate parameters - get_dyn_grid_info, &! Return dynamics grid column information physgrid_copy_attributes_d ! The Eulerian dynamics grids @@ -66,8 +63,6 @@ module dyn_grid type (hvcoord_t) :: hvcoord -type(physics_column_t), allocatable, target :: local_dyn_columns(:) - !======================================================================================== contains !======================================================================================== @@ -1212,106 +1207,6 @@ subroutine define_cam_grids() end subroutine define_cam_grids -!============================================================================== - -subroutine get_dyn_grid_info(hdim1_d, hdim2_d, num_lev, & - index_model_top_layer, index_surface_layer, unstructured, dyn_columns) - !------------------------------------------------------------ - ! - ! get_dyn_grid_info returns physics grid column information - ! - !------------------------------------------------------------ - use cam_abortutils, only: endrun - use spmd_utils, only: iam - use commap, only: londeg, latdeg, w - use pmgrid, only: beglat, endlat, plon, plat - ! Dummy arguments - integer, intent(out) :: hdim1_d ! # longitudes or grid size - integer, intent(out) :: hdim2_d ! # latitudes or 1 - integer, intent(out) :: num_lev ! # levels - integer, intent(out) :: index_model_top_layer - integer, intent(out) :: index_surface_layer - logical, intent(out) :: unstructured - ! dyn_columns will contain a copy of the physics column info local to this - ! dynamics task - type(physics_column_t), allocatable, intent(out) :: dyn_columns(:) - ! Local variables - integer :: blockid(1), bcid(1) - integer :: lindex - integer :: gindex - integer :: num_local_cols - integer :: ncol - integer :: ngcols - integer :: owner - integer :: indx - integer :: jndx - real(r8), allocatable :: clat_d(:), clon_d(:), area_d(:), wght_d(:) - real(r8), parameter :: radtodeg = 180.0_r8 / SHR_CONST_PI - real(r8), parameter :: degtorad = SHR_CONST_PI / 180.0_r8 - character(len=*), parameter :: subname = 'get_dyn_grid_info' - - unstructured = .false. ! EUL is an structured dycore - num_local_cols = plon*(endlat-beglat+1) - if (allocated(local_dyn_columns)) then - ! Check for correct number of columns - if (size(local_dyn_columns) /= num_local_cols) then - call endrun(subname//': called with inconsistent column numbers') - end if - else - allocate(local_dyn_columns(num_local_cols)) - end if - hdim1_d = plon - hdim2_d = plat - num_lev = plev - index_model_top_layer = 1 - index_surface_layer = plev - ngcols = plon*plat - allocate( clat_d(1:ngcols) ) - allocate( clon_d(1:ngcols) ) - allocate( area_d(1:ngcols) ) - allocate( wght_d(1:ngcols) ) - call get_horiz_grid_d(ngcols, clat_d_out=clat_d, clon_d_out=clon_d, area_d_out=area_d, wght_d_out=wght_d) - ncol = 0 - do gindex = 1,ngcols - call get_gcol_block_d( gindex, 1, blockid, bcid ) - owner = get_block_owner_d(blockid(1)) - if ( iam==owner ) then - ncol=ncol+1 - lindex = bcid(1) - local_dyn_columns(lindex)%lat_rad = clat_d(gindex) - local_dyn_columns(lindex)%lon_rad = clon_d(gindex) - local_dyn_columns(lindex)%lat_deg = clat_d(gindex) * rad2deg - local_dyn_columns(lindex)%lon_deg = clon_d(gindex) * rad2deg - local_dyn_columns(lindex)%lon_deg = area_d(gindex) - local_dyn_columns(lindex)%lon_deg = wght_d(gindex) - local_dyn_columns(lindex)%global_col_num = gindex - local_dyn_columns(lindex)%dyn_task = iam - local_dyn_columns(lindex)%local_dyn_block = blockid(1)-beglat+1 - local_dyn_columns(lindex)%global_dyn_block = blockid(1) - ! get global lat and lon coordinate indices from global column index - ! -- plon is global number of longitude grid points - jndx = (gindex-1)/plon + 1 - indx = gindex - (jndx-1)*plon - local_dyn_columns(lindex)%coord_indices(1)=indx - local_dyn_columns(lindex)%coord_indices(2)=jndx - end if - end do - ! Copy the information to the output array - if (allocated(dyn_columns)) then - deallocate(dyn_columns) - end if - allocate(dyn_columns(ncol)) - do lindex = 1, ncol - dyn_columns(lindex) = local_dyn_columns(lindex) - end do - - deallocate( clat_d ) - deallocate( clon_d ) - deallocate( area_d ) - deallocate( wght_d ) - - end subroutine get_dyn_grid_info - !======================================================================================== end module dyn_grid diff --git a/src/dynamics/eul/dynpkg.F90 b/src/dynamics/eul/dynpkg.F90 index 94fcec48f9..0d3a2810f7 100644 --- a/src/dynamics/eul/dynpkg.F90 +++ b/src/dynamics/eul/dynpkg.F90 @@ -1,14 +1,14 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & cwava ,detam ,flx_net ,ztodt ) -!----------------------------------------------------------------------- -! -! Purpose: +!----------------------------------------------------------------------- +! +! Purpose: ! Driving routines for dynamics and transport. -! -! Method: -! -! Author: +! +! Method: +! +! Author: ! Original version: CCM3 ! !----------------------------------------------------------------------- @@ -20,10 +20,9 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & use scanslt, only: scanslt_run, plond, platd, advection_state use scan2, only: scan2run use scamMod, only: single_column,scm_crm_mode,switch,wfldh -#if ( defined BFB_CAM_SCAM_IOP ) use iop, only: t2sav,fusav,fvsav -#endif use perf_mod + use cam_history, only: write_camiop !----------------------------------------------------------------------- implicit none @@ -36,7 +35,7 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & real(r8), intent(inout) :: fu(plon,plev,beglat:endlat) ! u wind tendency real(r8), intent(inout) :: fv(plon,plev,beglat:endlat) ! v wind tendency - real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints + real(r8), intent(in) :: etamid(plev) ! vertical coords at midpoints real(r8), intent(inout) :: cwava(plat) ! weight applied to global integrals real(r8), intent(inout) :: detam(plev) ! intervals between vert full levs. real(r8), intent(in) :: flx_net(plon,beglat:endlat) ! net flux from physics @@ -60,7 +59,7 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & real(r8) grd1(2*maxm,plev,plat/2) ! | real(r8) grd2(2*maxm,plev,plat/2) ! | real(r8) grfu1(2*maxm,plev,plat/2) ! |- see quad for definitions - real(r8) grfu2(2*maxm,plev,plat/2) ! | + real(r8) grfu2(2*maxm,plev,plat/2) ! | real(r8) grfv1(2*maxm,plev,plat/2) ! | real(r8) grfv2(2*maxm,plev,plat/2) ! | real(r8) grut1(2*maxm,plev,plat/2) ! | @@ -80,13 +79,13 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & ! SCANDYN Dynamics scan !---------------------------------------------------------- ! -#if ( defined BFB_CAM_SCAM_IOP ) -do c=beglat,endlat - t2sav(:plon,:,c)= t2(:plon,:,c) - fusav(:plon,:,c)= fu(:plon,:,c) - fvsav(:plon,:,c)= fv(:plon,:,c) -enddo -#endif +if (write_camiop) then + do c=beglat,endlat + t2sav(:plon,:,c)= t2(:plon,:,c) + fusav(:plon,:,c)= fu(:plon,:,c) + fvsav(:plon,:,c)= fv(:plon,:,c) + enddo +end if if ( single_column ) then etadot(1,:,1)=wfldh(:) @@ -150,4 +149,3 @@ subroutine dynpkg (adv_state, t2 ,fu ,fv ,etamid , & return end subroutine dynpkg - diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90 index 55cc4fad37..e020dbb443 100644 --- a/src/dynamics/eul/iop.F90 +++ b/src/dynamics/eul/iop.F90 @@ -1,10 +1,10 @@ module iop -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- !BOP ! ! !MODULE: iop -! -! !DESCRIPTION: +! +! !DESCRIPTION: ! iop specific routines ! ! !USES: @@ -21,14 +21,14 @@ module iop private - real(r8), allocatable,target :: dqfx3sav(:,:,:,:) - real(r8), allocatable,target :: t2sav(:,:,:) - real(r8), allocatable,target :: fusav(:,:,:) - real(r8), allocatable,target :: fvsav(:,:,:) + real(r8), allocatable,target :: dqfx3sav(:,:,:,:) + real(r8), allocatable,target :: t2sav(:,:,:) + real(r8), allocatable,target :: fusav(:,:,:) + real(r8), allocatable,target :: fvsav(:,:,:) real(r8), allocatable,target :: divq3dsav(:,:,:,:) - real(r8), allocatable,target :: divt3dsav(:,:,:) - real(r8), allocatable,target :: divu3dsav(:,:,:) - real(r8), allocatable,target :: divv3dsav(:,:,:) + real(r8), allocatable,target :: divt3dsav(:,:,:) + real(r8), allocatable,target :: divu3dsav(:,:,:) + real(r8), allocatable,target :: divv3dsav(:,:,:) real(r8), allocatable,target :: betasav(:) integer :: closelatidx,closelonidx,latid,lonid,levid,timeid @@ -50,7 +50,7 @@ module iop !EOP ! ! !PRIVATE MEMBER FUNCTIONS: -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- contains subroutine init_iop_fields() @@ -64,7 +64,7 @@ subroutine init_iop_fields() if (eul_nsplit>1) then call endrun('iop module cannot be used with eul_nsplit>1') endif - + if(.not.allocated(betasav)) then allocate (betasav(beglat:endlat)) betasav(:)=0._r8 @@ -129,14 +129,14 @@ subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3) ! set prognostics from iop ! Find level where tobs is no longer zero ioptop = minloc(tobs(:), 1, BACK=.true.)+1 - if (present(ps)) ps(1,1,timelevel) = psobs if (present(t3)) t3(1,ioptop:,1,timelevel) = tobs(ioptop:) + if (present(q3)) q3(1,ioptop:,1,1,timelevel) = qobs(ioptop:) +!!!!!jt revert next line only for bfb + ioptop=1 if (present(u3)) u3(1,ioptop:,1,timelevel) = uobs(ioptop:) if (present(v3)) v3(1,ioptop:,1,timelevel) = vobs(ioptop:) - if (present(q3)) q3(1,ioptop:,1,1,timelevel) = qobs(ioptop:) end subroutine iop_update_prognostics end module iop - diff --git a/src/dynamics/eul/restart_dynamics.F90 b/src/dynamics/eul/restart_dynamics.F90 index 348c2aa26c..dc80678f1b 100644 --- a/src/dynamics/eul/restart_dynamics.F90 +++ b/src/dynamics/eul/restart_dynamics.F90 @@ -9,11 +9,10 @@ module restart_dynamics pdeld, ps, vort, div, & dps, phis, dpsl, dpsm, omga, ptimelevels use scanslt, only: lammp, phimp, sigmp, qfcst -#if ( defined BFB_CAM_SCAM_IOP ) use iop, only: dqfx3sav,divq3dsav,divt3dsav,t2sav,betasav,fusav,fvsav -#endif use cam_logfile, only: iulog use spmd_utils, only: masterproc + use cam_history, only: write_camiop implicit none private @@ -125,7 +124,7 @@ subroutine init_restart_varlist() vcnt=vcnt+1 call set_r_var('PDELD', ptimelevels, vcnt, v4=pdeld ) - + vcnt=vcnt+1 call set_r_var('LAMMP', 1, vcnt, v3=lammp ) @@ -138,32 +137,32 @@ subroutine init_restart_varlist() call set_r_var('Q_fcst', 1, vcnt, v4=qfcst ) -#if ( defined BFB_CAM_SCAM_IOP ) -! -! Write scam values -! - vcnt=vcnt+1 - call set_r_var('DQFX', 1, vcnt, v4=dqfx3sav ) + if (write_camiop) then + ! + ! Write scam values + ! + vcnt=vcnt+1 + call set_r_var('DQFX', 1, vcnt, v4=dqfx3sav ) - vcnt=vcnt+1 - call set_r_var('DIVQ', 1, vcnt, v4=divq3dsav ) + vcnt=vcnt+1 + call set_r_var('DIVQ', 1, vcnt, v4=divq3dsav ) - vcnt=vcnt+1 - call set_r_var('DIVT', 1, vcnt, v3=divt3dsav ) + vcnt=vcnt+1 + call set_r_var('DIVT', 1, vcnt, v3=divt3dsav ) - vcnt=vcnt+1 - call set_r_var('T2', 1, vcnt, v3=t2sav ) + vcnt=vcnt+1 + call set_r_var('T2', 1, vcnt, v3=t2sav ) - vcnt=vcnt+1 - call set_r_var('FU', 1, vcnt, v3=fusav ) + vcnt=vcnt+1 + call set_r_var('FU', 1, vcnt, v3=fusav ) - vcnt=vcnt+1 - call set_r_var('FV', 1, vcnt, v3=fvsav ) + vcnt=vcnt+1 + call set_r_var('FV', 1, vcnt, v3=fvsav ) - vcnt=vcnt+1 - call set_r_var('BETA', 1, vcnt, v1=betasav ) + vcnt=vcnt+1 + call set_r_var('BETA', 1, vcnt, v1=betasav ) -#endif + end if if(vcnt.ne.restartvarcnt) then write(iulog,*) 'vcnt= ',vcnt, ' restartvarcnt=',restartvarcnt @@ -231,11 +230,11 @@ subroutine init_restart_dynamics(File, dyn_out) qdims(1:2) = hdimids(1:2) qdims(3) = vdimids(1) qdims(5) = timelevels_dimid - + call init_restart_varlist() do i=1,restartvarcnt - + call get_restart_var(i, name, timelevels, ndims, vdesc) if(timelevels>1) then if(ndims==3) then @@ -356,15 +355,15 @@ subroutine write_restart_dynamics (File, dyn_out) else if(ndims==5) then call pio_write_darray(File, vdesc, iodesc4d, transfer(restartvars(i)%v5d(:,:,:,:,ct), mold), ierr) end if - + end do - + end if end do call pio_freedecomp(File, iodesc2d) call pio_freedecomp(File, iodesc3d) call pio_freedecomp(File, iodesc4d) - + return end subroutine write_restart_dynamics @@ -393,10 +392,8 @@ subroutine read_restart_dynamics (File, dyn_in, dyn_out) use pmgrid, only: plon, plat, beglat, endlat use ppgrid, only: pver - -#if ( defined BFB_CAM_SCAM_IOP ) + use iop, only: init_iop_fields -#endif use massfix, only: alpha, hw1, hw2, hw3 use prognostics, only: n3m2, n3m1, n3 @@ -467,9 +464,8 @@ subroutine read_restart_dynamics (File, dyn_in, dyn_out) call init_restart_varlist() -#if ( defined BFB_CAM_SCAM_IOP ) - call init_iop_fields() -#endif + if (write_camiop) call init_iop_fields() + do i=1,restartvarcnt call get_restart_var(i, name, timelevels, ndims, vdesc) @@ -533,13 +529,13 @@ function get_restart_decomp(hdim1, hdim2, nlev) result(ldof) endlatxy = get_dyn_grid_parm('endlatxy') plat = get_dyn_grid_parm('plat') - - + + lcnt=(endlatxy-beglatxy+1)*nlev*(endlonxy-beglonxy+1) allocate(ldof(lcnt)) lcnt=0 - ldof(:)=0 + ldof(:)=0 do j=beglatxy,endlatxy do k=1,nlev do i=beglonxy, endlonxy diff --git a/src/dynamics/eul/scmforecast.F90 b/src/dynamics/eul/scmforecast.F90 index 1489a50ef5..8dcab1d136 100644 --- a/src/dynamics/eul/scmforecast.F90 +++ b/src/dynamics/eul/scmforecast.F90 @@ -1,11 +1,11 @@ module scmforecast - ! --------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------- ! ! ! ! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', ! - ! 'horizontal advection', and 'vertical advection' tendencies. ! - ! This module is used only for SCAM. ! - ! ! - ! --------------------------------------------------------------------------- ! + ! 'horizontal advection', and 'vertical advection' tendencies. ! + ! This module is used only for SCAM. ! + ! ! + ! --------------------------------------------------------------------------- ! use spmd_utils, only: masterproc use cam_logfile, only: iulog use cam_control_mod, only: adiabatic @@ -19,26 +19,26 @@ module scmforecast ! Private module data ! -!======================================================================= +!======================================================================= contains -!======================================================================= +!======================================================================= - subroutine forecast( lat , nlon , ztodt , & + subroutine forecast( lat , nlon , ztodt , & psm1 , psm2 , ps , & u3 , u3m1 , u3m2 , & v3 , v3m1 , v3m2 , & t3 , t3m1 , t3m2 , & - q3 , q3m1 , q3m2 , & + q3 , q3m1 , q3m2 , & tten_phys , uten_phys , vten_phys , & qminus , qfcst ) - ! --------------------------------------------------------------------------- ! + ! --------------------------------------------------------------------------- ! ! ! ! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', ! - ! 'horizontal advection', and 'vertical advection' tendencies. ! - ! This module is used only for SCAM. ! - ! ! + ! 'horizontal advection', and 'vertical advection' tendencies. ! + ! This module is used only for SCAM. ! + ! ! ! Author : Sungsu Park. 2010. Sep. ! ! ! ! --------------------------------------------------------------------------- ! @@ -79,8 +79,8 @@ subroutine forecast( lat , nlon , ztodt , & ! x3 : final state variable after time-marching ! ! --------------------------------------------------- ! - integer, intent(in) :: lat - integer, intent(in) :: nlon + integer, intent(in) :: lat + integer, intent(in) :: nlon real(r8), intent(in) :: ztodt ! Twice time step unless nstep = 0 [ s ] real(r8), intent(in) :: ps(plon) ! Surface pressure [ Pa ] @@ -100,7 +100,7 @@ subroutine forecast( lat , nlon , ztodt , & real(r8), intent(inout) :: uten_phys(plev) ! Tendency of u by the sum of 'physics + geostrophic forcing' [ m/s/s ] real(r8), intent(inout) :: vten_phys(plev) ! Tendency of v by the sum of 'physics + geostrophic forcing' [ m/s/s ] real(r8) qten_phys(plev,pcnst) ! Tendency of q by the 'physics' [ #/kg/s, kg/kg/s ] - real(r8), intent(in) :: qminus(plon,plev,pcnst) ! ( qminus - q3m2 ) / ztodt = Tendency of tracers by the 'physics' [ #/kg/s, kg/kg/s ] + real(r8), intent(in) :: qminus(plon,plev,pcnst) ! ( qminus - q3m2 ) / ztodt = Tendency of tracers by the 'physics' [ #/kg/s, kg/kg/s ] real(r8), intent(out) :: t3(plev) ! Temperature [ K ] real(r8), intent(out) :: u3(plev) ! Zonal wind [ m/s ] @@ -115,16 +115,16 @@ subroutine forecast( lat , nlon , ztodt , & integer dummy integer dummy_dyndecomp - integer i, k, m + integer i, k, m integer ixcldliq, ixcldice, ixnumliq, ixnumice, ioptop real(r8) weight, fac - real(r8) pmidm1(plev) - real(r8) pintm1(plevp) - real(r8) pdelm1(plev) - real(r8) wfldint(plevp) - real(r8) pdelb(plon,plev) + real(r8) pmidm1(plev) + real(r8) pintm1(plevp) + real(r8) pdelm1(plev) + real(r8) wfldint(plevp) + real(r8) pdelb(plon,plev) real(r8) tfcst(plev) ! ( tfcst - t3m2 ) / ztodt = Tendency of T by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ K/s ] - real(r8) ufcst(plev) ! ( ufcst - u3m2 ) / ztodt = Tendency of u by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ m/s/s ] + real(r8) ufcst(plev) ! ( ufcst - u3m2 ) / ztodt = Tendency of u by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ m/s/s ] real(r8) vfcst(plev) ! ( vfcst - u3m2 ) / ztodt = Tendency of v by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ m/s/s ] logical scm_fincl_empty ! ----------------------------------------------- ! @@ -132,8 +132,8 @@ subroutine forecast( lat , nlon , ztodt , & ! ----------------------------------------------- ! real(r8) tten_zadv_EULc(plev) ! Vertical advective forcing of t [ K/s ] - real(r8) uten_zadv_EULc(plev) ! Vertical advective forcing of u [ m/s/s ] - real(r8) vten_zadv_EULc(plev) ! Vertical advective forcing of v [ m/s/s ] + real(r8) uten_zadv_EULc(plev) ! Vertical advective forcing of u [ m/s/s ] + real(r8) vten_zadv_EULc(plev) ! Vertical advective forcing of v [ m/s/s ] real(r8) qten_zadv_EULc(plev,pcnst) ! Vertical advective forcing of tracers [ #/kg/s, kg/kg/s ] ! --------------------------------- ! @@ -145,15 +145,15 @@ subroutine forecast( lat , nlon , ztodt , & ! Eulerian compression heating ! ! ---------------------------- ! - real(r8) tten_comp_EUL(plev) ! Compression heating by vertical advection [ K/s ] - + real(r8) tten_comp_EUL(plev) ! Compression heating by vertical advection [ K/s ] + ! ----------------------------------- ! ! Final vertical advective tendencies ! - ! ----------------------------------- ! + ! ----------------------------------- ! real(r8) tten_zadv(plev) ! Vertical advective forcing of t [ K/s ] - real(r8) uten_zadv(plev) ! Vertical advective forcing of u [ m/s/s ] - real(r8) vten_zadv(plev) ! Vertical advective forcing of v [ m/s/s ] + real(r8) uten_zadv(plev) ! Vertical advective forcing of u [ m/s/s ] + real(r8) vten_zadv(plev) ! Vertical advective forcing of v [ m/s/s ] real(r8) qten_zadv(plev,pcnst) ! Vertical advective forcing of tracers [ #/kg/s, kg/kg/s ] ! --------------------------- ! @@ -210,12 +210,12 @@ subroutine forecast( lat , nlon , ztodt , & 'use_obs_T ', scm_use_obs_T , & 'relaxation ', scm_relaxation , & 'use_3dfrc ', use_3dfrc - + !---BPM ! ---------------------------- ! - ! ! + ! ! ! Main Computation Begins Here ! ! ! ! ---------------------------- ! @@ -240,19 +240,19 @@ subroutine forecast( lat , nlon , ztodt , & ! Note 'tten_phys, uten_phys, vten_phys' are already input. ! ! ------------------------------------------------------------ ! - qten_phys(:plev,:pcnst) = ( qminus(1,:plev,:pcnst) - q3m2(:plev,:pcnst) ) / ztodt + qten_phys(:plev,:pcnst) = ( qminus(1,:plev,:pcnst) - q3m2(:plev,:pcnst) ) / ztodt ! ----------------------------------------------------- ! ! Extract SLT-transported vertical advective tendencies ! ! TODO : Add in SLT transport of t u v as well ! ! ----------------------------------------------------- ! - qten_zadv_SLT(:plev,:pcnst) = ( qfcst(1,:plev,:pcnst) - qminus(1,:plev,:pcnst) ) / ztodt + qten_zadv_SLT(:plev,:pcnst) = ( qfcst(1,:plev,:pcnst) - qminus(1,:plev,:pcnst) ) / ztodt ! ------------------------------------------------------- ! - ! use_camiop = .true. : Use CAM-generated 3D IOP file ! - ! = .false. : Use User-generated SCAM IOP file ! - ! ------------------------------------------------------- ! + ! use_camiop = .true. : Use CAM-generated 3D IOP file ! + ! = .false. : Use User-generated SCAM IOP file ! + ! ------------------------------------------------------- ! if( use_camiop ) then @@ -261,7 +261,7 @@ subroutine forecast( lat , nlon , ztodt , & ufcst(k) = u3m2(k) + ztodt * uten_phys(k) + ztodt * divu3d(k) vfcst(k) = v3m2(k) + ztodt * vten_phys(k) + ztodt * divv3d(k) do m = 1, pcnst - ! Below two lines are identical but in order to reproduce the bit-by-bit results + ! Below two lines are identical but in order to reproduce the bit-by-bit results ! of CAM-3D simulation, I simply rewrite the 'original' into the 'expanded' one. ! Below is the 'original' one. ! qfcst(1,k,m) = q3m2(k,m) + ztodt * ( qten_phys(k,m) + divq3d(k,m) ) @@ -273,18 +273,18 @@ subroutine forecast( lat , nlon , ztodt , & else ! ---------------------------------------------------------------------------- ! - ! Compute 'omega'( wfldint ) at the interface from the value at the mid-point. ! + ! Compute 'omega'( wfldint ) at the interface from the value at the mid-point. ! ! SCAM-IOP file must provide omega at the mid-point not at the interface. ! ! ---------------------------------------------------------------------------- ! - + wfldint(1) = 0._r8 do k = 2, plev weight = ( pintm1(k) - pmidm1(k-1) ) / ( pmidm1(k) - pmidm1(k-1) ) wfldint(k) = ( 1._r8 - weight ) * wfld(k-1) + weight * wfld(k) enddo wfldint(plevp) = 0._r8 - - ! ------------------------------------------------------------ ! + + ! ------------------------------------------------------------ ! ! Compute Eulerian compression heating due to vertical motion. ! ! ------------------------------------------------------------ ! @@ -293,13 +293,13 @@ subroutine forecast( lat , nlon , ztodt , & enddo ! ---------------------------------------------------------------------------- ! - ! Compute Centered Eulerian vertical advective tendencies for all 't, u, v, q' ! - ! ---------------------------------------------------------------------------- ! + ! Compute Centered Eulerian vertical advective tendencies for all 't, u, v, q' ! + ! ---------------------------------------------------------------------------- ! do k = 2, plev - 1 fac = 1._r8 / ( 2.0_r8 * pdelm1(k) ) tten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( t3m1(k+1) - t3m1(k) ) + wfldint(k) * ( t3m1(k) - t3m1(k-1) ) ) - vten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( v3m1(k+1) - v3m1(k) ) + wfldint(k) * ( v3m1(k) - v3m1(k-1) ) ) + vten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( v3m1(k+1) - v3m1(k) ) + wfldint(k) * ( v3m1(k) - v3m1(k-1) ) ) uten_zadv_EULc(k) = -fac * ( wfldint(k+1) * ( u3m1(k+1) - u3m1(k) ) + wfldint(k) * ( u3m1(k) - u3m1(k-1) ) ) do m = 1, pcnst qten_zadv_EULc(k,m) = -fac * ( wfldint(k+1) * ( q3m1(k+1,m) - q3m1(k,m) ) + wfldint(k) * ( q3m1(k,m) - q3m1(k-1,m) ) ) @@ -325,7 +325,7 @@ subroutine forecast( lat , nlon , ztodt , & end do ! ------------------------------------- ! - ! Manupulate individual forcings before ! + ! Manupulate individual forcings before ! ! computing the final forecasted state ! ! ------------------------------------- ! @@ -380,20 +380,20 @@ subroutine forecast( lat , nlon , ztodt , & ! -------------------------------------------------------------- ! ! Check horizontal advection u,v,t,q ! ! -------------------------------------------------------------- ! - if (.not. have_divu) divu=0._r8 - if (.not. have_divv) divv=0._r8 - if (.not. have_divt) divt=0._r8 - if (.not. have_divq) divq=0._r8 + if (.not. have_divu) divu=0._r8 + if (.not. have_divv) divv=0._r8 + if (.not. have_divt) divt=0._r8 + if (.not. have_divq) divq=0._r8 ! ----------------------------------- ! - ! ! + ! ! ! Compute the final forecasted states ! ! ! - ! ----------------------------------- ! + ! ----------------------------------- ! ! make sure we have everything ! - ! ----------------------------------- ! + ! ----------------------------------- ! - if( .not. scm_use_obs_uv .and. .not. have_divu .and. .not. have_divv ) then + if( .not. scm_use_obs_uv .and. .not. have_divu .and. .not. have_divv ) then call endrun( subname//':: divu and divv not on the iop Unable to forecast Wind Set & scm_use_obs_uv=true to use observed u and v') end if @@ -409,7 +409,7 @@ subroutine forecast( lat , nlon , ztodt , & ufcst(k) = u3m2(k) + ztodt * ( uten_phys(k) + divu(k) + uten_zadv(k) ) vfcst(k) = v3m2(k) + ztodt * ( vten_phys(k) + divv(k) + vten_zadv(k) ) do m = 1, pcnst - qfcst(1,k,m) = q3m2(k,m) + ztodt * ( qten_phys(k,m) + divq(k,m) + qten_zadv(k,m) ) + qfcst(1,k,m) = q3m2(k,m) + ztodt * ( qten_phys(k,m) + divq(k,m) + qten_zadv(k,m) ) enddo enddo @@ -454,34 +454,34 @@ subroutine forecast( lat , nlon , ztodt , & ! at each time step if specified by the switch. ! ! If SCAM-IOP has 't,u,v,q' profile at a single initial time step. ! ! ---------------------------------------------------------------- ! - - if( scm_use_obs_T .and. have_t ) then + + if( scm_use_obs_T .and. have_t ) then do k = 1, plev tfcst(k) = tobs(k) enddo endif - - if( scm_use_obs_uv .and. have_u .and. have_v ) then - ufcst=u3 - vfcst=v3 - ufcst(ioptop:plev)=uobs(ioptop:plev) - vfcst(ioptop:plev)=vobs(ioptop:plev) - ufcst(:plev)=uobs(:plev) - vfcst(:plev)=vobs(:plev) + + if( scm_use_obs_uv .and. have_u .and. have_v ) then + ufcst(:plev) = uobs(:plev) + vfcst(:plev) = vobs(:plev) endif - - if( scm_use_obs_qv .and. have_q ) then + + if( scm_use_obs_qv .and. have_q ) then do k = 1, plev qfcst(1,k,1) = qobs(k) enddo endif - + + !Fill out tobs/qobs with background CAM state above IOP top before t3/q3 update below + tobs(1:ioptop-1)=t3(1:ioptop-1) + qobs(1:ioptop-1)=q3(1:ioptop-1,1) + ! ------------------------------------------------------------------- ! ! Relaxation to the observed or specified state ! ! We should specify relaxation time scale ( rtau ) and ! ! target-relaxation state ( in the current case, either 'obs' or 0 ) ! ! ------------------------------------------------------------------- ! - + relax_T(:) = 0._r8 relax_u(:) = 0._r8 relax_v(:) = 0._r8 @@ -517,11 +517,11 @@ subroutine forecast( lat , nlon , ztodt , & endif ! +BPM: this can't be the best way... ! I put this in because if rtau doesn't get set above, then I don't want to do any relaxation in that layer. - ! maybe the logic of this whole loop needs to be re-thinked. + ! maybe the logic of this whole loop needs to be re-thinked. if (rtau(k).ne.0) then relax_T(k) = - ( tfcst(k) - tobs(k) ) / rtau(k) relax_u(k) = - ( ufcst(k) - uobs(k) ) / rtau(k) - relax_v(k) = - ( vfcst(k) - vobs(k) ) / rtau(k) + relax_v(k) = - ( vfcst(k) - vobs(k) ) / rtau(k) relax_q(k,1) = - ( qfcst(1,k,1) - qobs(k) ) / rtau(k) do m = 2, pcnst relax_q(k,m) = - ( qfcst(1,k,m) - qinitobs(k,m) ) / rtau(k) @@ -543,31 +543,22 @@ subroutine forecast( lat , nlon , ztodt , & call outfld( 'TRELAX' , relax_T , plon, dummy ) call outfld( 'QRELAX' , relax_q(1:plev,1) , plon, dummy ) call outfld( 'TAURELAX' , rtau , plon, dummy ) - + ! --------------------------------------------------------- ! ! Assign the final forecasted state to the output variables ! ! --------------------------------------------------------- ! - !Fill out tobs/qobs with background CAM state above IOP top before t3 update below - tobs(1:ioptop-1)=t3(1:ioptop-1) - qobs(1:ioptop-1)=q3(1:ioptop-1,1) + t3(1:plev) = tfcst(1:plev) + u3(1:plev) = ufcst(1:plev) + v3(1:plev) = vfcst(1:plev) + q3(1:plev,1:pcnst) = qfcst(1,1:plev,1:pcnst) - t3(:plev)=tfcst(:plev) - u3(:plev)=ufcst(:plev) - v3(:plev)=vfcst(:plev) - q3(:plev,:pcnst)=qfcst(1,:plev,:pcnst) - -!!$ t3(1:plev) = tfcst(1:plev) -!!$ u3(1:plev) = ufcst(1:plev) -!!$ v3(1:plev) = vfcst(1:plev) -!!$ q3(1:plev,1:pcnst) = qfcst(1,1:plev,1:pcnst) - tdiff(1:plev) = t3(1:plev) - tobs(1:plev) qdiff(1:plev) = q3(1:plev,1) - qobs(1:plev) - call outfld( 'QDIFF' , qdiff, plon, dummy ) - call outfld( 'TDIFF' , tdiff, plon, dummy ) - + call outfld( 'QDIFF' , qdiff, plon, dummy_dyndecomp ) + call outfld( 'TDIFF' , tdiff, plon, dummy_dyndecomp ) + return end subroutine forecast diff --git a/src/dynamics/eul/stepon.F90 b/src/dynamics/eul/stepon.F90 index 02e7064fb3..b19caa605c 100644 --- a/src/dynamics/eul/stepon.F90 +++ b/src/dynamics/eul/stepon.F90 @@ -23,7 +23,7 @@ module stepon use aerosol_state_mod, only: aerosol_state use microp_aero, only: aerosol_state_object, aerosol_properties_object use dyn_grid, only: hvcoord - + implicit none private save @@ -75,12 +75,11 @@ subroutine stepon_init(dyn_in, dyn_out) use dyn_comp, only: dyn_import_t, dyn_export_t use scanslt, only: scanslt_initial use commap, only: clat + use cam_history, only: write_camiop use constituents, only: pcnst use physconst, only: gravit use eul_control_mod,only: eul_nsplit -#if ( defined BFB_CAM_SCAM_IOP ) use iop, only:init_iop_fields -#endif !----------------------------------------------------------------------- ! Arguments ! @@ -151,11 +150,9 @@ subroutine stepon_init(dyn_in, dyn_out) call t_stopf ('stepon_startup') -#if ( defined BFB_CAM_SCAM_IOP ) - if (is_first_step()) then + if (is_first_step() .and. write_camiop) then call init_iop_fields() endif -#endif ! get aerosol properties aero_props_obj => aerosol_properties_object() @@ -296,7 +293,7 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) use eul_control_mod,only: eul_nsplit use prognostics, only: ps use iop, only: iop_update_prognostics - + real(r8), intent(in) :: ztodt ! twice time step unless nstep=0 type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) type(physics_state), intent(in):: phys_state(begchunk:endchunk) @@ -316,7 +313,6 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) if (doiopupdate) then call readiopdata(hvcoord) -!jt call iop_update_prognostics(n3,ps=ps(:,:,:)) call iop_update_prognostics(n3,ps=ps) end if endif diff --git a/src/dynamics/eul/tfilt_massfix.F90 b/src/dynamics/eul/tfilt_massfix.F90 index a603c38fc9..afe65bb2b5 100644 --- a/src/dynamics/eul/tfilt_massfix.F90 +++ b/src/dynamics/eul/tfilt_massfix.F90 @@ -38,7 +38,7 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 use cam_control_mod, only: ideal_phys, tj2016_phys - use cam_history, only: outfld + use cam_history, only: outfld, write_camiop use eul_control_mod, only: fixmas,eps use pmgrid, only: plon, plev, plevp, plat use commap, only: clat @@ -51,10 +51,9 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & use phys_control, only: phys_getopts use qneg_module, only: qneg3 -#if ( defined BFB_CAM_SCAM_IOP ) use iop use constituents, only: cnst_get_ind, cnst_name -#endif + implicit none ! @@ -139,12 +138,10 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & ! real(r8) engk ! Kinetic energy integral ! real(r8) engp ! Potential energy integral integer i, k, m,j,ixcldliq,ixcldice,ixnumliq,ixnumice -#if ( defined BFB_CAM_SCAM_IOP ) real(r8) :: u3forecast(plon,plev) real(r8) :: v3forecast(plon,plev) real(r8) :: t3forecast(plon,plev),delta_t3(plon,plev) real(r8) :: q3forecast(plon,plev,pcnst),delta_q3(plon,plev,pcnst) -#endif real(r8) fixmas_plon(plon) real(r8) beta_plon(plon) real(r8) clat_plon(plon) @@ -152,64 +149,63 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & !----------------------------------------------------------------------- nstep = get_nstep() -#if ( defined BFB_CAM_SCAM_IOP ) -! -! Calculate 3d dynamics term -! - do k=1,plev - do i=1,nlon - divt3dsav(i,k,lat)=(t3(i,k)-tm2(i,k))/ztodt -t2sav(i,k,lat) - divu3dsav(i,k,lat)=(u3(i,k)-um2(i,k))/ztodt -fusav(i,k,lat) - divv3dsav(i,k,lat)=(v3(i,k)-vm2(i,k))/ztodt -fvsav(i,k,lat) - t3forecast(i,k)=tm2(i,k)+ztodt*t2sav(i,k,lat)+ztodt*divt3dsav(i,k,lat) - u3forecast(i,k)=um2(i,k)+ztodt*fusav(i,k,lat)+ztodt*divu3dsav(i,k,lat) - v3forecast(i,k)=vm2(i,k)+ztodt*fvsav(i,k,lat)+ztodt*divv3dsav(i,k,lat) + if (write_camiop) then + ! + ! Calculate 3d dynamics term + ! + do k=1,plev + do i=1,nlon + divt3dsav(i,k,lat)=(t3(i,k)-tm2(i,k))/ztodt -t2sav(i,k,lat) + divu3dsav(i,k,lat)=(u3(i,k)-um2(i,k))/ztodt -fusav(i,k,lat) + divv3dsav(i,k,lat)=(v3(i,k)-vm2(i,k))/ztodt -fvsav(i,k,lat) + t3forecast(i,k)=tm2(i,k)+ztodt*t2sav(i,k,lat)+ztodt*divt3dsav(i,k,lat) + u3forecast(i,k)=um2(i,k)+ztodt*fusav(i,k,lat)+ztodt*divu3dsav(i,k,lat) + v3forecast(i,k)=vm2(i,k)+ztodt*fvsav(i,k,lat)+ztodt*divv3dsav(i,k,lat) + end do end do - end do - do i=1,nlon - do m=1,pcnst - do k=1,plev - divq3dsav(i,k,m,lat)= (qfcst(i,k,m)-qminus(i,k,m))/ztodt - q3forecast(i,k,m)=qminus(i,k,m)+divq3dsav(i,k,m,lat)*ztodt + do i=1,nlon + do m=1,pcnst + do k=1,plev + divq3dsav(i,k,m,lat)= (qfcst(i,k,m)-qminus(i,k,m))/ztodt + q3forecast(i,k,m)=qminus(i,k,m)+divq3dsav(i,k,m,lat)*ztodt + end do end do end do - end do - q3(:nlon,:,:)=q3forecast(:nlon,:,:) - t3(:nlon,:)=t3forecast(:nlon,:) - qfcst(:nlon,:,:)=q3(:nlon,:,:) - -! -! outflds for iop history tape - to get bit for bit with scam -! the n-1 values are put out. After the fields are written out -! the current time level of info will be buffered for output next -! timestep -! - call outfld('t',t3 ,plon ,lat ) - call outfld('q',q3 ,plon ,lat ) - call outfld('Ps',ps ,plon ,lat ) - call outfld('u',u3 ,plon ,lat ) - call outfld('v',v3 ,plon ,lat ) -! -! read single values into plon arrays for output to history tape -! it would be nice if history tape supported 1 dimensional array variables -! - fixmas_plon(:)=fixmas - beta_plon(:)=beta - clat_plon(:)=clat(lat) - - call outfld('fixmas',fixmas_plon,plon ,lat ) - call outfld('beta',beta_plon ,plon ,lat ) - call outfld('CLAT ',clat_plon ,plon ,lat ) - call outfld('divT3d',divt3dsav(1,1,lat) ,plon ,lat ) - call outfld('divU3d',divu3dsav(1,1,lat) ,plon ,lat ) - call outfld('divV3d',divv3dsav(1,1,lat) ,plon ,lat ) - do m =1,pcnst - call outfld(trim(cnst_name(m))//'_dten',divq3dsav(1,1,m,lat) ,plon ,lat ) - end do -#endif - + q3(:nlon,:,:)=q3forecast(:nlon,:,:) + t3(:nlon,:)=t3forecast(:nlon,:) + qfcst(:nlon,:,:)=q3(:nlon,:,:) + + ! + ! outflds for iop history tape - to get bit for bit with scam + ! the n-1 values are put out. After the fields are written out + ! the current time level of info will be buffered for output next + ! timestep + ! + call outfld('t',t3 ,plon ,lat ) + call outfld('q',q3 ,plon ,lat ) + call outfld('Ps',ps ,plon ,lat ) + call outfld('u',u3 ,plon ,lat ) + call outfld('v',v3 ,plon ,lat ) + ! + ! read single values into plon arrays for output to history tape + ! it would be nice if history tape supported 1 dimensional array variables + ! + fixmas_plon(:)=fixmas + beta_plon(:)=beta + clat_plon(:)=clat(lat) + + call outfld('fixmas',fixmas_plon,plon ,lat ) + call outfld('beta',beta_plon ,plon ,lat ) + call outfld('CLAT ',clat_plon ,plon ,lat ) + call outfld('divT3d',divt3dsav(1,1,lat) ,plon ,lat ) + call outfld('divU3d',divu3dsav(1,1,lat) ,plon ,lat ) + call outfld('divV3d',divv3dsav(1,1,lat) ,plon ,lat ) + do m =1,pcnst + call outfld(trim(cnst_name(m))//'_dten',divq3dsav(1,1,m,lat) ,plon ,lat ) + end do + end if coslat = cos(clat(lat)) do i=1,nlon @@ -291,9 +287,12 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & dqfx3(i,k,m) = dqfxcam(i,k,m) else dqfx3(i,k,m) = alpha(m)*etamid(k)*abs(qfcst(i,k,m) - qminus(i,k,m)) -#if ( defined BFB_CAM_SCAM_IOP ) - dqfx3sav(i,k,m,lat) = dqfx3(i,k,m) -#endif +!!$#if ( defined BFB_CAM_SCAM_IOP ) +!!$ dqfx3sav(i,k,m,lat) = dqfx3(i,k,m) +!!$#endif + if (write_camiop) then + dqfx3sav(i,k,m,lat) = dqfx3(i,k,m) + endif endif end do if (lfixlim) then @@ -333,14 +332,13 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & end do ! i end do ! k - -#if ( defined BFB_CAM_SCAM_IOP ) - do m=1,pcnst - alpha_plon(:)= alpha(m) - call outfld(trim(cnst_name(m))//'_alph',alpha_plon ,plon ,lat ) - call outfld(trim(cnst_name(m))//'_dqfx',dqfx3sav(1,1,m,lat) ,plon ,lat ) - end do -#endif + if (write_camiop) then + do m=1,pcnst + alpha_plon(:)= alpha(m) + call outfld(trim(cnst_name(m))//'_alph',alpha_plon ,plon ,lat ) + call outfld(trim(cnst_name(m))//'_dqfx',dqfx3sav(1,1,m,lat) ,plon ,lat ) + end do + end if ! ! Check for and correct invalid constituents ! diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index 92637be444..853ccb4ddd 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -18,125 +18,6 @@ module apply_iop_forcing_mod contains !========================================================================= -!$$subroutine advance_iop_forcing(scm_dt ,hvcoord ,psm1 , & ! In -!$$ u3m1 ,u3m2 ,u_phys_frc , & ! In -!$$ v3m1 ,v3m2 ,v_phys_frc , & ! In -!$$ t3m1 ,t3m2 ,t_phys_frc , & ! In -!$$ q3m1 ,q3m2 ,q_phys_frc , & ! In -!$$ u3 ,v3 ,t3 , & ! Out -!$$ q3 ) ! Out -!$$!----------------------------------------------------------------------- -!$$! -!$$! Purpose: -!$$! --------------------------------------------------------------------------- ! -!$$! ! -!$$! Compute Time-Marched 'T, u, v, q' for SCAM by summing the 'physics', ! -!$$! 'horizontal advection', and 'vertical advection' tendencies. ! -!$$! This module is used only for SCAM. ! -!$$! ! -!$$! --------------------------------------------------------------------------- ! -!$$! -!$$! Author: -!$$! Original version: Adopted from CAM3.5/CAM5 -!$$! Substantially refactored by Sung Su Park -!$$! Updated for SE dycore: Peter Bogenschutz (bogenschutz1@llnl.gov) John Truesdale (jet.ucar.edu) -!$$! -!$$! --------------------------------------------------- -!$$! x = t, u, v, q -!$$! x3m1 : state variable used for computing 'forcing' -!$$! x3m2 : initial state variable before time-marching -!$$! x3 : final state variable after time-marching -!$$!----------------------------------------------------------------------- -!$$ -!$$! Input arguments -!$$ real(r8), intent(in) :: scm_dt ! model time step [s] -!$$ type (hvcoord_t), intent(in) :: hvcoord -!$$ real(r8), intent(in) :: psm1 ! surface pressure [Pa] -!$$ real(r8), intent(in) :: u3m1(plev) ! Zonal wind [ m/s ] -!$$ real(r8), intent(in) :: u3m2(plev) ! Zonal wind [ m/s ] -!$$ real(r8), intent(in) :: u_phys_frc(plev) ! Zonal wind [ m/s ] -!$$ real(r8), intent(in) :: v3m1(plev) ! Meridional wind [ m/s ] -!$$ real(r8), intent(in) :: v3m2(plev) ! Meridional wind [ m/s ] -!$$ real(r8), intent(in) :: v_phys_frc(plev) ! Meridional wind [ m/s ] -!$$ real(r8), intent(in) :: t3m1(plev) ! temperature [K] -!$$ real(r8), intent(in) :: t3m2(plev) ! temperature [K] -!$$ real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] -!$$ real(r8), intent(in) :: q3m1(plev,pcnst) ! Meridional wind [ m/s ] -!$$ real(r8), intent(in) :: q3m2(plev,pcnst) ! Meridional wind [ m/s ] -!$$ real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! temperature forcing from physics [K/s] -!$$ -!$$ ! Output arguments -!$$ real(r8), intent(out) :: t3(plev) ! updated temperature [K] -!$$ real(r8), intent(out) :: q3(plev,pcnst)! updated q tracer array [units vary] -!$$ real(r8), intent(out) :: u3(plev) ! updated zonal wind [m/s] -!$$ real(r8), intent(out) :: v3(plev) ! updated meridional wind [m/s] -!$$ -!$$ ! Local variables -!$$ real(r8) pmidm1(plev) ! pressure at model levels -!$$ real(r8) pintm1(plevp) ! pressure at model interfaces -!$$ real(r8) pdelm1(plev) ! pdel(k) = pint (k+1)-pint (k) -!$$ real(r8) t_lsf(plev) ! storage for temperature large scale forcing -!$$ real(r8) q_lsf(plev,pcnst) ! storage for moisture large scale forcing -!$$ real(r8) qten_phys(plev,pcnst) ! storage for moisture large scale forcing -!$$ real(r8) fac, t_expan -!$$ -!$$ integer i,k,m ! longitude, level, constituent indices -!$$ integer ixcldliq, ixcldice, ixnumliq, ixnumice -!$$ -!$$ ! Main Computation Begins Here ! -!$$ call cnst_get_ind( 'CLDLIQ', ixcldliq, abort=.false. ) -!$$ call cnst_get_ind( 'CLDICE', ixcldice, abort=.false. ) -!$$ call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) -!$$ call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) -!$$ -!$$ ! Calculate midpoint pressure levels ! -!$$ call plevs0(plev ,psm1 ,pintm1 ,pmidm1 ,pdelm1, hvcoord) -!$$ -!$$ -!$$ ! Extract physical tendencies of tracers q. -!$$ ! Note 'tten_phys, uten_phys, vten_phys' are already input. -!$$ qten_phys(:plev,:pcnst) = ( q_phys_frc(:plev,:pcnst) - q3m2(:plev,:pcnst) ) / scm_dt -!$$ -!$$ -!$$!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!$$ ! Advance T and Q due to large scale forcing -!$$ -!$$ if (use_3dfrc .or. have_divt3d) then -!$$ t_lsf(:plev) = divt3d(:plev) -!$$ q_lsf(:plev,:pcnst) = divq3d(:plev,:pcnst) -!$$ else -!$$ t_lsf(:plev) = divt(:plev) -!$$ q_lsf(:plev,:pcnst) = divq(:plev,:pcnst) -!$$ endif -!$$ -!$$ do k=1,plev -!$$ ! Initialize thermal expansion term to zero. This term is only -!$$ ! considered if using the preq-x dycore and if three dimensional -!$$ ! forcing is not provided by IOP forcing file. -!$$ t_expan = 0._r8 -!$$ -!$$!!$ if (.not. use_3dfrc) then -!$$!!$ t_expan = scm_dt*wfld(k)*t3m1(k)*rair/(cpair*pmidm1(k)) -!$$!!$ endif -!$$!!$ t_update(k) = t3m1(k) + t_expan + scm_dt*(t_phys_frc(k) + t_lsf(k)) -!$$ t3(k) = t3m1(k) + scm_dt*(t_phys_frc(k) + t_lsf(k)) -!$$ do m=1,pcnst -!$$ q3(k,m) = scm_dt*(q_phys_frc(k,m) + q_lsf(k,m)) -!$$ end do -!$$ enddo -!$$ -!$$ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!$$ ! Set U and V fields -!$$ -!$$ if ( have_v .and. have_u ) then -!$$ do k=1,plev -!$$ u3(k) = uobs(k) -!$$ v3(k) = vobs(k) -!$$ enddo -!$$ endif -!$$ -!$$end subroutine advance_iop_forcing -!$$ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In u_in, v_in, t_in, q_in, t_phys_frc, q_phys_frc, hvcoord, & ! In u_update, v_update, t_update, q_update) ! Out @@ -184,14 +65,11 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In character(len=*), parameter :: subname = 'advance_iop_forcing' - !! Get vertical level profiles - + ! Get vertical level profiles nlon = 1 ! number of columns for plevs0 routine call plevs0(plev ,ps_in ,pintm1 ,pmidm1 ,pdelm1, hvcoord) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance T and Q due to large scale forcing - if (use_3dfrc) then if(.not.(have_divt3d.and.have_divq3d)) call endrun(subname//": FATAL: divt3d and divq3d not available") t_lsf(:plev) = divt3d(:plev) @@ -205,11 +83,11 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In ! Initialize thermal expansion term to zero. This term is only ! considered if three dimensional forcing is not provided by IOP forcing file. t_expan = 0._r8 - + if (.not. use_3dfrc) then t_expan = scm_dt*wfld(k)*t_in(k)*rair/(cpair*pmidm1(k)) endif - + if (use_3dfrc) then do m=1,pcnst ! When using 3d dynamics tendencies, SCM skips the vertical advection step and thus @@ -226,7 +104,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In t_update(k) = t_in(k) + t_expan + scm_dt*t_lsf(k) end if end do - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Set U and V fields if ( have_v .and. have_u ) then @@ -279,22 +157,12 @@ subroutine advance_iop_nudging(scm_dt, ps_in, t_in, q_in, hvcoord, & ! In end do do k=1,plev - -!jt if (pmidm1(k) .le. iop_nudge_tq_low*100._r8 .and. & -!jt pmidm1(k) .ge. iop_nudge_tq_high*100._r8) then - - ! Set the relaxation time scale -!jt rtau(k) = iop_nudge_tscale -!jt rtau(k) = max(scm_dt,rtau(k)) rtau(k) = scm_dt relaxt(k) = -(t_update(k) - tobs(k))/rtau(k) relaxq(k) = -(q_update(k) - qobs(k))/rtau(k) t_update(k) = t_update(k) + relaxt(k)*scm_dt q_update(k) = q_update(k) + relaxq(k)*scm_dt - -!jt endif - end do end subroutine advance_iop_nudging @@ -302,5 +170,3 @@ end subroutine advance_iop_nudging !----------------------------------------------------------------------- end module apply_iop_forcing_mod - - diff --git a/src/dynamics/se/dycore/prim_advance_mod.F90 b/src/dynamics/se/dycore/prim_advance_mod.F90 index b0a71d5ee6..ed7a627ec4 100644 --- a/src/dynamics/se/dycore/prim_advance_mod.F90 +++ b/src/dynamics/se/dycore/prim_advance_mod.F90 @@ -1725,8 +1725,6 @@ subroutine compute_omega(hybrid,n0,qn0,elem,deriv,nets,nete,dt,hvcoord) use viscosity_mod, only: biharmonic_wk_omega use cam_thermo, only: get_dp, MASS_MIXING_RATIO use air_composition,only: thermodynamic_active_species_idx_dycore - use cam_logfile, only: iulog - implicit none type (hybrid_t) , intent(in) :: hybrid type (element_t) , intent(inout), target :: elem(:) diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index 9e4eea35d3..fc11b3b93f 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -62,7 +62,7 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) ! variables used to calculate CFL real (kind=r8) :: dtnu ! timestep*viscosity parameter real (kind=r8) :: dt_dyn_vis ! viscosity timestep used in dynamics - real (kind=r8) :: dt_dyn_del2_sponge, dt_remap + real (kind=r8) :: dt_dyn_del2_sponge, dt_remap real (kind=r8) :: dt_tracer_vis ! viscosity timestep used in tracers real (kind=r8) :: dp,dp0,T1,T0,pmid_ref(np,np) @@ -163,7 +163,7 @@ subroutine prim_init2(elem, fvm, hybrid, nets, nete, tl, hvcoord) do k=1,nlev pmid_ref =hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*ps_ref(:,:,ie) dp0 = ( hvcoord%hyai(k+1) - hvcoord%hyai(k) )*hvcoord%ps0 + & - ( hvcoord%hybi(k+1) - hvcoord%hybi(k) )*hvcoord%ps0 + ( hvcoord%hybi(k+1) - hvcoord%hybi(k) )*hvcoord%ps0 if (hvcoord%hybm(k)>0) then elem(ie)%derived%T_ref(:,:,k) = T0+T1*(pmid_ref/hvcoord%ps0)**cappa ! @@ -239,7 +239,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst type (TimeLevel_t), intent(inout):: tl integer, intent(in) :: nsubstep ! nsubstep = 1 .. nsplit logical, intent(in) :: single_column - real (kind=r8) , intent(inout):: omega_cn(2,nets:nete) !min and max of vertical Courant number + real (kind=r8) , intent(inout):: omega_cn(2,nets:nete) !min and max of vertical Courant number real(kind=r8) :: dt_q, dt_remap, dt_phys integer :: ie, q,k,n0_qdp,np1_qdp,r, nstep_end,region_num_threads,i,j @@ -267,7 +267,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst ! ! initialize variables for computing vertical Courant number ! - if (variable_nsplit.or.compute_diagnostics) then + if (variable_nsplit.or.compute_diagnostics) then if (nsubstep==1) then do ie=nets,nete omega_cn(1,ie) = 0.0_r8 @@ -285,7 +285,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dAF') call ApplyCAMForcing(elem,fvm,tl%n0,n0_qdp,dt_remap,dt_phys,nets,nete,nsubstep) - call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') + call tot_energy_dyn(elem,fvm,nets,nete,tl%n0,n0_qdp,'dBD') do r=1,rsplit if (r.ne.1) call TimeLevel_update(tl,"leapfrog") if (single_column) then @@ -298,6 +298,7 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst end if enddo + ! defer final timelevel update until after remap and diagnostics call TimeLevel_Qdp( tl, qsplit, n0_qdp, np1_qdp) @@ -307,12 +308,12 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst ! always for tracers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAD') + call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAD') if (variable_nsplit.or.compute_diagnostics) then ! ! initialize variables for computing vertical Courant number - ! + ! do ie=nets,nete dp_end(:,:,:,ie) = elem(ie)%state%dp3d(:,:,:,tl%np1) end do @@ -326,9 +327,8 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call tot_energy_dyn(elem,fvm,nets,nete,tl%np1,np1_qdp,'dAR') -!!jt check with pel that we don't want to update omega here for scm if (nsubstep==nsplit.and. .not. single_column) then - call compute_omega(hybrid,tl%np1,np1_qdp,elem,deriv,nets,nete,dt_remap,hvcoord) + call compute_omega(hybrid,tl%np1,np1_qdp,elem,deriv,nets,nete,dt_remap,hvcoord) end if ! now we have: @@ -429,8 +429,8 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) #ifdef waccm_debug use cam_history, only: outfld -#endif - +#endif + type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) @@ -548,20 +548,20 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) if (qsize > 0) then call t_startf('prim_advec_tracers_remap') - if(use_cslam) then + if(use_cslam) then ! Deactivate threading in the tracer dimension if this is a CSLAM run region_num_threads = 1 else region_num_threads=tracer_num_threads - endif + endif call omp_set_nested(.true.) !$OMP PARALLEL NUM_THREADS(region_num_threads), DEFAULT(SHARED), PRIVATE(hybridnew) - if(use_cslam) then + if(use_cslam) then ! Deactivate threading in the tracer dimension if this is a CSLAM run hybridnew = config_thread_region(hybrid,'serial') else hybridnew = config_thread_region(hybrid,'tracer') - endif + endif call Prim_Advec_Tracers_remap(elem, deriv,hvcoord,hybridnew,dt_q,tl,nets,nete) !$OMP END PARALLEL call omp_set_nested(.false.) @@ -574,7 +574,7 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! ! FVM transport ! - if ((mod(rstep,fvm_supercycling) == 0).and.(mod(rstep,fvm_supercycling_jet) == 0)) then + if ((mod(rstep,fvm_supercycling) == 0).and.(mod(rstep,fvm_supercycling_jet) == 0)) then ! call omp_set_nested(.true.) ! !$OMP PARALLEL NUM_THREADS(vert_num_threads), DEFAULT(SHARED), PRIVATE(hybridnew2,kbeg,kend) @@ -609,7 +609,7 @@ subroutine prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! call Prim_Advec_Tracers_fvm(elem,fvm,hvcoord,hybrid,& dt_q,tl,nets,nete,ghostBufQnhcJet_h,ghostBufQ1_h, ghostBufFluxJet_h,kmin_jet,kmax_jet) - end if + end if #ifdef waccm_debug do ie=nets,nete @@ -626,7 +626,7 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! Here we simply want to compute the floating level tendency ! based on the prescribed large scale vertical velocity ! Take qsplit dynamics steps and one tracer step - ! for vertically lagrangian option, this subroutine does only + ! for vertically lagrangian option, this subroutine does only ! the horizontal step ! ! input: @@ -642,7 +642,7 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! tl%n0 time t + dt_q ! use hybvcoord_mod, only: hvcoord_t - use time_mod, only: TimeLevel_t, timelevel_update + use se_dyn_time_mod, only: TimeLevel_t, timelevel_update use control_mod, only: statefreq, qsplit, nu_p use thread_mod, only: omp_get_thread_num use prim_advance_mod, only: prim_advance_exp @@ -656,8 +656,8 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) #ifdef waccm_debug use cam_history, only: outfld -#endif - +#endif + type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) @@ -688,7 +688,6 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! for use by advection ! =============== do ie=nets,nete -!jt elem(ie)%derived%eta_dot_dpdn=0 ! mean vertical mass flux elem(ie)%derived%vn0=0 ! mean horizontal mass flux if (nu_p>0) then elem(ie)%derived%dpdiss_ave=0 @@ -832,14 +831,14 @@ subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & use element_mod, only: element_t use hybvcoord_mod, only: hvcoord_t use hybrid_mod, only: hybrid_t - use time_mod, only: TimeLevel_t, timelevel_qdp, tevolve + use se_dyn_time_mod, only: TimeLevel_t, timelevel_qdp, tevolve use fvm_control_volume_mod, only: fvm_struct use cam_thermo, only: get_kappa_dry use air_composition, only: thermodynamic_active_species_num use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp use physconst, only: cpair implicit none - + type (element_t), intent(inout), target :: elem(:) type(fvm_struct) , intent(inout) :: fvm(:) type (derivative_t) , intent(in) :: deriv @@ -849,34 +848,34 @@ subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & type (TimeLevel_t) , intent(in) :: tl integer , intent(in) :: nets integer , intent(in) :: nete - + ! Local integer :: ie,nm1,n0,np1,k,qn0,qnp1,m_cnst, nq,p real(kind=r8) :: eta_dot_dpdn(np,np,nlev+1) - - + + call t_startf('prim_advance_exp') nm1 = tl%nm1 n0 = tl%n0 np1 = tl%np1 - + call TimeLevel_Qdp(tl, qsplit, qn0, qnp1) ! compute current Qdp() timelevel - + do ie=nets,nete do k=1,nlev eta_dot_dpdn(:,:,k)=elem(ie)%derived%omega(:,:,k) enddo eta_dot_dpdn(:,:,nlev+1) = eta_dot_dpdn(:,:,nlev) - + do k=1,nlev elem(ie)%state%dp3d(:,:,k,np1) = elem(ie)%state%dp3d(:,:,k,n0) & + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) enddo - + do k=1,nlev elem(ie)%state%T(:,:,k,np1) = elem(ie)%state%T(:,:,k,n0) enddo - + do p=1,qsize do k=1,nlev elem(ie)%state%Qdp(:,:,k,p,qnp1) = elem(ie)%state%Qdp(:,:,k,p,qn0) & diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index f769c478a8..9a5d684c87 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -47,8 +47,7 @@ module dyn_comp use edgetype_mod, only: EdgeBuffer_t use bndry_mod, only: bndry_exchange use se_single_column_mod, only: scm_setinitial -use scamMod, only: single_column, have_divT3d, readiopdata, use_iop, setiopupdate_init, & - scmlon, scmlat +use scamMod, only: single_column, readiopdata, use_iop, setiopupdate_init implicit none private @@ -588,10 +587,6 @@ subroutine dyn_init(dyn_in, dyn_out) use air_composition, only: thermodynamic_active_species_liq_idx_dycore,thermodynamic_active_species_ice_idx_dycore use air_composition, only: thermodynamic_active_species_liq_num, thermodynamic_active_species_ice_num use cam_history, only: addfld, add_default, horiz_only, register_vector_field -#if (defined BFB_CAM_SCAM_IOP ) - use history_defaults, only: initialize_iop_history -#endif - use gravity_waves_sources, only: gws_init use thread_mod, only: horz_num_threads @@ -749,10 +744,6 @@ subroutine dyn_init(dyn_in, dyn_out) nullify(dyn_out%fvm) end if -#ifdef BFB_CAM_SCAM_IOP - call initialize_iop_history -#endif - call set_phis(dyn_in) if (initial_run) then @@ -953,13 +944,11 @@ subroutine dyn_init(dyn_in, dyn_out) do m = 1, pcnst call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(cnst_name(m))//' horz + vert', & gridname='FVM') - call add_default(tottnam(m), 2, ' ') end do else do m = 1, pcnst call addfld(tottnam(m),(/ 'lev' /),'A','kg/kg/s',trim(cnst_name(m))//' horz + vert', & gridname='GLL') - call add_default(tottnam(m), 2, ' ') end do end if call phys_getopts(history_budget_out=history_budget, history_budget_histfile_num_out=budget_hfile_num) @@ -981,14 +970,12 @@ subroutine dyn_run(dyn_state) use air_composition, only: thermodynamic_active_species_idx_dycore use prim_driver_mod, only: prim_run_subcycle use dimensions_mod, only: cnst_name_gll - use se_dyn_time_mod, only: tstep, nsplit, timelevel_qdp + use se_dyn_time_mod, only: tstep, nsplit, timelevel_qdp, tevolve use hybrid_mod, only: config_thread_region, get_loop_ranges use control_mod, only: qsplit, rsplit, ftype_conserve use thread_mod, only: horz_num_threads - use time_mod, only: tevolve use scamMod, only: single_column, use_3dfrc use se_single_column_mod, only: apply_SC_forcing,ie_scm - use se_dyn_time_mod, only: tevolve type(dyn_export_t), intent(inout) :: dyn_state @@ -1020,152 +1007,148 @@ subroutine dyn_run(dyn_state) if (iam >= par%nprocs) return if (.not. use_3dfrc ) then + ldiag = hist_fld_active('ABS_dPSdt') + if (ldiag) then + allocate(ps_before(np,np,nelemd)) + allocate(abs_ps_tend(np,np,nelemd)) - ldiag = hist_fld_active('ABS_dPSdt') - if (ldiag) then - allocate(ps_before(np,np,nelemd)) - allocate(abs_ps_tend(np,np,nelemd)) - - end if - - !$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(hybrid,nets,nete,n,ie,m,i,j,k,ftmp) - hybrid = config_thread_region(par,'horizontal') - call get_loop_ranges(hybrid, ibeg=nets, iend=nete) - - dtime = get_step_size() - rec2dt = 1._r8/dtime - - tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics - call TimeLevel_Qdp(TimeLevel, qsplit, n0_qdp)!get n0_qdp for diagnostics call - - ! output physics forcing - if (hist_fld_active('FU') .or. hist_fld_active('FV') .or.hist_fld_active('FT')) then - do ie = nets, nete - do k = 1, nlev - do j = 1, np - do i = 1, np - ftmp(i+(j-1)*np,k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) - ftmp(i+(j-1)*np,k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) - ftmp(i+(j-1)*np,k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) - end do + end if + + !$OMP PARALLEL NUM_THREADS(horz_num_threads), DEFAULT(SHARED), PRIVATE(hybrid,nets,nete,n,ie,m,i,j,k,ftmp) + hybrid = config_thread_region(par,'horizontal') + call get_loop_ranges(hybrid, ibeg=nets, iend=nete) + + dtime = get_step_size() + rec2dt = 1._r8/dtime + + tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics + call TimeLevel_Qdp(TimeLevel, qsplit, n0_qdp)!get n0_qdp for diagnostics call + + ! output physics forcing + if (hist_fld_active('FU') .or. hist_fld_active('FV') .or.hist_fld_active('FT')) then + do ie = nets, nete + do k = 1, nlev + do j = 1, np + do i = 1, np + ftmp(i+(j-1)*np,k,1) = dyn_state%elem(ie)%derived%FM(i,j,1,k) + ftmp(i+(j-1)*np,k,2) = dyn_state%elem(ie)%derived%FM(i,j,2,k) + ftmp(i+(j-1)*np,k,3) = dyn_state%elem(ie)%derived%FT(i,j,k) end do end do - - call outfld('FU', ftmp(:,:,1), npsq, ie) - call outfld('FV', ftmp(:,:,2), npsq, ie) - call outfld('FT', ftmp(:,:,3), npsq, ie) end do - end if - + + call outfld('FU', ftmp(:,:,1), npsq, ie) + call outfld('FV', ftmp(:,:,2), npsq, ie) + call outfld('FT', ftmp(:,:,3), npsq, ie) + end do + end if + + do m = 1, qsize + if (hist_fld_active('F'//trim(cnst_name_gll(m))//'_gll')) then + do ie = nets, nete + call outfld('F'//trim(cnst_name_gll(m))//'_gll',& + RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/)), npsq, ie) + end do + end if + end do + + + + ! convert elem(ie)%derived%fq to mass tendency + do ie = nets, nete do m = 1, qsize - if (hist_fld_active('F'//trim(cnst_name_gll(m))//'_gll')) then - do ie = nets, nete - call outfld('F'//trim(cnst_name_gll(m))//'_gll',& - RESHAPE(dyn_state%elem(ie)%derived%FQ(:,:,:,m), (/np*np,nlev/)), npsq, ie) + do k = 1, nlev + do j = 1, np + do i = 1, np + dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & + rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + end do end do - end if + end do end do - - - - ! convert elem(ie)%derived%fq to mass tendency + end do + + + if (ftype_conserve>0) then + do ie = nets, nete + do k=1,nlev + do j=1,np + do i = 1, np + pdel = dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + do nq=dry_air_species_num+1,thermodynamic_active_species_num + m_cnst = thermodynamic_active_species_idx_dycore(nq) + pdel = pdel + (dyn_state%elem(ie)%state%qdp(i,j,k,m_cnst,n0_qdp)+dyn_state%elem(ie)%derived%FQ(i,j,k,m_cnst)*dtime) + end do + dyn_state%elem(ie)%derived%FDP(i,j,k) = pdel + end do + end do + end do + end do + end if + + + if (use_cslam) then do ie = nets, nete - do m = 1, qsize + do m = 1, ntrac do k = 1, nlev - do j = 1, np - do i = 1, np - dyn_state%elem(ie)%derived%FQ(i,j,k,m) = dyn_state%elem(ie)%derived%FQ(i,j,k,m)* & - rec2dt*dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) + do j = 1, nc + do i = 1, nc + dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & + rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) end do end do end do end do end do - - - if (ftype_conserve>0) then + end if + + if (ldiag) then + abs_ps_tend(:,:,nets:nete) = 0.0_r8 + endif + + do n = 1, nsplit_local + + if (ldiag) then do ie = nets, nete - do k=1,nlev - do j=1,np - do i = 1, np - pdel = dyn_state%elem(ie)%state%dp3d(i,j,k,tl_f) - do nq=dry_air_species_num+1,thermodynamic_active_species_num - m_cnst = thermodynamic_active_species_idx_dycore(nq) - pdel = pdel + (dyn_state%elem(ie)%state%qdp(i,j,k,m_cnst,n0_qdp)+dyn_state%elem(ie)%derived%FQ(i,j,k,m_cnst)*dtime) - end do - dyn_state%elem(ie)%derived%FDP(i,j,k) = pdel - end do - end do - end do + ps_before(:,:,ie) = dyn_state%elem(ie)%state%psdry(:,:) end do end if - - - if (use_cslam) then - do ie = nets, nete - do m = 1, ntrac - do k = 1, nlev - do j = 1, nc - do i = 1, nc - dyn_state%fvm(ie)%fc(i,j,k,m) = dyn_state%fvm(ie)%fc(i,j,k,m)* & - rec2dt!*dyn_state%fvm(ie)%dp_fvm(i,j,k) - end do - end do - end do - end do - end do + + ! forward-in-time RK, with subcycling + if (single_column) then + nets_in=ie_scm + nete_in=ie_scm + else + nets_in=nets + nete_in=nete end if - - - - if (ldiag) then - abs_ps_tend(:,:,nets:nete) = 0.0_r8 - endif - - do n = 1, nsplit_local - - if (ldiag) then - do ie = nets, nete - ps_before(:,:,ie) = dyn_state%elem(ie)%state%psdry(:,:) - end do - end if - - ! forward-in-time RK, with subcycling - if (single_column) then - nets_in=ie_scm - nete_in=ie_scm - else - nets_in=nets - nete_in=nete - end if - call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets_in, nete_in, & - tstep, TimeLevel, hvcoord, n, single_column, omega_cn) - - if (ldiag) then - do ie = nets, nete - abs_ps_tend(:,:,ie) = abs_ps_tend(:,:,ie) + & - ABS(ps_before(:,:,ie)-dyn_state%elem(ie)%state%psdry(:,:)) & - /(tstep*qsplit*rsplit) - end do - end if - - end do - + call prim_run_subcycle(dyn_state%elem, dyn_state%fvm, hybrid, nets_in, nete_in, & + tstep, TimeLevel, hvcoord, n, single_column, omega_cn) + if (ldiag) then - do ie=nets,nete - abs_ps_tend(:,:,ie)=abs_ps_tend(:,:,ie)/DBLE(nsplit) - call outfld('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/)),npsq,ie) + do ie = nets, nete + abs_ps_tend(:,:,ie) = abs_ps_tend(:,:,ie) + & + ABS(ps_before(:,:,ie)-dyn_state%elem(ie)%state%psdry(:,:)) & + /(tstep*qsplit*rsplit) end do end if - - !$OMP END PARALLEL - if (ldiag) then - deallocate(ps_before,abs_ps_tend) - endif + end do + if (ldiag) then + do ie=nets,nete + abs_ps_tend(:,:,ie)=abs_ps_tend(:,:,ie)/DBLE(nsplit) + call outfld('ABS_dPSdt',RESHAPE(abs_ps_tend(:,:,ie),(/npsq/)),npsq,ie) + end do end if + !$OMP END PARALLEL + + if (ldiag) then + deallocate(ps_before,abs_ps_tend) + endif + + end if ! not use_3dfrc if (single_column) then call apply_SC_forcing(dyn_state%elem,hvcoord,TimeLevel,3,.false.,nets,nete) @@ -1377,7 +1360,6 @@ subroutine read_inidat(dyn_in) if (.not. single_column) then call check_file_layout(fh_ini, elem, dyn_cols, 'ncdata', .true.) end if - ! Read 2-D field fieldname = 'PS' @@ -1896,10 +1878,14 @@ subroutine set_phis(dyn_in) ! Set name of grid object which will be used to read data from file ! into internal data structure via PIO. - if (fv_nphys == 0) then - grid_name = 'GLL' + if (single_column) then + grid_name = 'SCM' else - grid_name = 'physgrid_d' + if (fv_nphys == 0) then + grid_name = 'GLL' + else + grid_name = 'physgrid_d' + end if end if ! Get number of global columns from the grid object and check that @@ -1913,7 +1899,7 @@ subroutine set_phis(dyn_in) call endrun(sub//': dimension ncol not found in bnd_topo file') end if ierr = pio_inq_dimlen(fh_topo, ncol_did, ncol_size) - if (ncol_size /= dyn_cols) then + if (ncol_size /= dyn_cols .and. .not. single_column) then if (masterproc) then write(iulog,*) sub//': ncol_size=', ncol_size, ' : dyn_cols=', dyn_cols end if @@ -2075,7 +2061,7 @@ subroutine check_file_layout(file, elem, dyn_cols, file_desc, dyn_ok) end if ierr = pio_inq_dimlen(file, ncol_did, ncol_size) - if (ncol_size /= dyn_cols .and. .not. single_column) then + if (ncol_size /= dyn_cols) then if (masterproc) then write(iulog, '(a,2(a,i0))') trim(sub), ': ncol_size=', ncol_size, & ' : dyn_cols=', dyn_cols diff --git a/src/dynamics/se/dyn_grid.F90 b/src/dynamics/se/dyn_grid.F90 index 293f7402dd..e6b8318d0f 100644 --- a/src/dynamics/se/dyn_grid.F90 +++ b/src/dynamics/se/dyn_grid.F90 @@ -59,6 +59,7 @@ module dyn_grid integer, parameter :: fvm_decomp = 102 ! The FVM (CSLAM) grid integer, parameter :: physgrid_d = 103 ! physics grid on dynamics decomp integer, parameter :: ini_decomp = 104 ! alternate dynamics grid for reading initial file +integer, parameter :: ini_decomp_scm = 205 ! alternate dynamics grid for reading initial file character(len=3), protected :: ini_grid_name ! Name of horizontal grid dimension in initial file. @@ -732,8 +733,8 @@ subroutine define_cam_grids() use cam_grid_support, only: horiz_coord_t, horiz_coord_create use cam_grid_support, only: cam_grid_register, cam_grid_attribute_register use dimensions_mod, only: nc - use shr_const_mod, only: PI => SHR_CONST_PI - + use shr_const_mod, only: PI => SHR_CONST_PI + use scamMod, only: closeioplon,closeioplat,closeioplonidx,single_column ! Local variables integer :: i, ii, j, k, ie, mapind character(len=8) :: latname, lonname, ncolname, areaname @@ -741,6 +742,7 @@ subroutine define_cam_grids() type(horiz_coord_t), pointer :: lat_coord type(horiz_coord_t), pointer :: lon_coord integer(iMap), pointer :: grid_map(:,:) + integer(iMap), pointer :: grid_map_scm(:,:) !grid_map decomp for single column mode real(r8), allocatable :: pelat_deg(:) ! pe-local latitudes (degrees) real(r8), allocatable :: pelon_deg(:) ! pe-local longitudes (degrees) @@ -748,6 +750,8 @@ subroutine define_cam_grids() real(r8), pointer :: pearea_wt(:) ! pe-local areas normalized for unit sphere integer(iMap) :: fdofP_local(npsq,nelemd) ! pe-local map for dynamics decomp integer(iMap), allocatable :: pemap(:) ! pe-local map for PIO decomp + integer(iMap), allocatable :: pemap_scm(:) ! pe-local map for single column PIO decomp + real(r8) :: latval(1),lonval(1) integer :: ncols_fvm, ngcols_fvm real(r8), allocatable :: fvm_coord(:) @@ -859,7 +863,6 @@ subroutine define_cam_grids() ! If dim name is 'ncol', create INI grid ! We will read from INI grid, but use GLL grid for all output if (trim(ini_grid_hdim_name) == 'ncol') then - lat_coord => horiz_coord_create('lat', 'ncol', ngcols_d, & 'latitude', 'degrees_north', 1, size(pelat_deg), pelat_deg, map=pemap) lon_coord => horiz_coord_create('lon', 'ncol', ngcols_d, & @@ -894,6 +897,42 @@ subroutine define_cam_grids() ! to it. It can be nullified. nullify(grid_map) + !--------------------------------- + ! Create SCM grid object when running single column mode + !--------------------------------- + + if ( single_column) then + allocate(pemap_scm(1)) + pemap_scm = 0_iMap + pemap_scm = closeioplonidx + + ! Map for scm grid + allocate(grid_map_scm(3,npsq)) + grid_map_scm = 0_iMap + mapind = 1 + j = 1 + do i = 1, npsq + grid_map_scm(1, mapind) = i + grid_map_scm(2, mapind) = j + grid_map_scm(3, mapind) = pemap_scm(1) + mapind = mapind + 1 + end do + latval=closeioplat + lonval=closeioplon + + lat_coord => horiz_coord_create('lat', 'ncol', 1, & + 'latitude', 'degrees_north', 1, 1, latval, map=pemap_scm) + lon_coord => horiz_coord_create('lon', 'ncol', 1, & + 'longitude', 'degrees_east', 1, 1, lonval, map=pemap_scm) + + call cam_grid_register('SCM', ini_decomp_scm, lat_coord, lon_coord, & + grid_map_scm, block_indexed=.false., unstruct=.true.) + deallocate(pemap_scm) + ! grid_map cannot be deallocated as the cam_filemap_t object just points + ! to it. It can be nullified. + nullify(grid_map_scm) + end if + !--------------------------------- ! Create FVM grid object for CSLAM !--------------------------------- diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index af6dce74db..9f916a7c9e 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -1,6 +1,6 @@ module se_single_column_mod !-------------------------------------------------------- -! +! ! Module for the SE single column model use shr_kind_mod, only: r8=>shr_kind_r8 @@ -16,7 +16,7 @@ module se_single_column_mod use dimensions_mod, only: nelemd, np, nlev use time_manager, only: get_nstep, is_first_step, get_step_size, is_first_restart_step use ppgrid, only: begchunk -use time_mod, only: timelevel_qdp +use se_dyn_time_mod, only: timelevel_qdp use cam_history, only: outfld implicit none @@ -83,17 +83,13 @@ subroutine scm_setinitial(elem) tobs(:)=elem(ie_scm)%state%T(i_scm,j_scm,:,tl_f) qobs(:)=elem(ie_scm)%state%qdp(i_scm,j_scm,:,1,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:,tl_f) endif - + if (get_nstep() .eq. 0) then - !jt do cix = 1, pcnst - !jt if (scm_zero_non_iop_tracers) elem(ie_scm)%state%qdp(i,j,:,cix,tl_qdp_np0) = qmin(cix)*elem(ie_scm)%state%dp3d(i,j,:,tl_qdp_np0) - !jt elem(ie_scm)%state%qdp(ii,j,:,cix,tl_fqdp) = qmin(cix)*elem(ie_scm)%state%dp3d(ii,j,:,tl_f) - !jt end do do k=thelev, NLEV if (have_t) elem(ie_scm)%state%T(i_scm,j_scm,k,tl_f)=tobs(k) if (have_q) elem(ie_scm)%state%qdp(i_scm,j_scm,k,1,tl_fqdp)=qobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) enddo - + do k=1,NLEV if (have_ps) elem(ie_scm)%state%psdry(i_scm,j_scm) = psobs if (have_u) elem(ie_scm)%state%v(i_scm,j_scm,1,k,tl_f) = uobs(k) @@ -104,11 +100,11 @@ subroutine scm_setinitial(elem) if (have_cldice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldice,tl_fqdp) = cldiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) if (have_omega) elem(ie_scm)%derived%omega(i_scm,j_scm,k) = wfld(k) enddo - + endif - + endif - + end subroutine scm_setinitial subroutine scm_setfield(elem,iop_update_phase1) @@ -143,112 +139,49 @@ subroutine scm_setfield(elem,iop_update_phase1) vobs(k) = elem(ie_scm)%state%v(i_scm,j_scm,2,k,tl_f) end if end do - + end subroutine scm_setfield subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) -! +! use scamMod, only: single_column, use_3dfrc use dimensions_mod, only: np, nlev, npsq,qsize_d use hybvcoord_mod, only: hvcoord_t use element_mod, only: element_t use physconst, only: rair - use time_mod + use se_dyn_time_mod,only: TimeLevel_t use time_manager, only: get_nstep use control_mod, only: qsplit use apply_iop_forcing_mod, only:advance_iop_forcing, advance_iop_nudging use ppgrid, only:begchunk - integer :: n,nets,nete - type (element_t) , intent(inout), target :: elem(:) - type (hvcoord_t) :: hvcoord - type (TimeLevel_t), intent(in) :: tl - logical :: t_before_advance - - integer :: tl_qdp_np0,tl_qdp_np1 - integer :: ie,k,i,j,t,m - real (r8), dimension(nlev) :: p - real (r8) ::dt - - integer ::nelemd_todo, np_todo - logical ::scm_multcols = .false. - logical ::iop_nudge_tq = .false. - - -!$$ real (r8), pointer :: q_phys_frc(:,:) -!$$ real (r8) :: q3m2(nlev,pcnst), q3m1(nlev,pcnst),q3(nlev,pcnst) -!$$ real (r8), pointer :: t_phys_frc(:), u_phys_frc(:), v_phys_frc(:),t_vfcst(:),u_vfcst(:),v_vfcst(:) -!$$ real (r8), dimension(nlev) :: t3, u3, v3 -!$$ real (r8), pointer :: t3m1(:), u3m1(:), v3m1(:), t3m2(:), u3m2(:), v3m2(:) -!$$ real (r8), pointer :: psm1 -!$$ real (r8), dimension(nlev) :: relaxt, relaxq -!$$ real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn -!$$ real (r8), dimension(npsq,nlev) :: tdiff_out, qdiff_out -!$$ real (r8) :: etamid(nlev) -!$$ - real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update, q_phys_frc - real (r8), dimension(nlev) :: t_phys_frc, t_update, u_update, v_update - real (r8), dimension(nlev) :: t_in, u_in, v_in - real (r8), dimension(nlev) :: relaxt, relaxq - real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn - -!----------------------------------------------------------------------- + + type (element_t), intent(inout), target :: elem(:) + type (hvcoord_t), intent(in) :: hvcoord + type (TimeLevel_t), intent(in) :: tl + logical, intent(in) :: t_before_advance + integer, intent(in) :: n,nets,nete + + integer :: tl_qdp_np0,tl_qdp_np1 + integer :: ie,k,i,j,t,m + real (r8), dimension(nlev) :: p + real (r8) :: dt + + integer :: nelemd_todo, np_todo + logical :: scm_multcols = .false. + logical :: iop_nudge_tq = .false. + + real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update, q_phys_frc + real (r8), dimension(nlev) :: t_phys_frc, t_update, u_update, v_update + real (r8), dimension(nlev) :: t_in, u_in, v_in + real (r8), dimension(nlev) :: relaxt, relaxq + real (r8), dimension(nlev) :: tdiff_dyn, qdiff_dyn + +!----------------------------------------------------------------------- tl_f = tl%n0 call TimeLevel_Qdp(tl, qsplit, tl_fqdp) -!$$ dt = get_step_size() -!$$ -!$$ ! Set initial profiles for current column -!$$ do m=1,pcnst -!$$ q3m2(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) -!$$ q3m1(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) -!$$!jt qminus(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f)+q_phys_frc(:nlev) -!$$ end do -!$$ t_vfcst => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%n0) -!$$ u_vfcst => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%n0) -!$$ v_vfcst => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%n0) -!$$ u3m2 => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%n0) -!$$ v3m2 => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%n0) -!$$ t3m2 => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%n0) -!$$ u3m1 => elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl%nm1) -!$$ v3m1 => elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl%nm1) -!$$ t3m1 => elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl%nm1) -!$$ psm1 => elem(ie_scm)%state%psdry(i_scm,j_scm) -!$$!!$ if (.not. use_3dfrc ) then -!$$!!$ t_phys_frc(:) = 0.0_r8 -!$$!!$ else -!$$ t_phys_frc => elem(ie_scm)%derived%fT(i_scm,j_scm,:) -!$$ u_phys_frc => elem(ie_scm)%derived%FM(i_scm,j_scm,1,:) -!$$ v_phys_frc => elem(ie_scm)%derived%FM(i_scm,j_scm,2,:) -!$$!jt q_phys_frc => elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:)*dt/elem(ie_scm)%stat -!$$!jt qminus(:nlev) = q3m2+q_phys_frc(:,:) -!$$!!$ endif -!$$ -!$$ do k=1,nlev -!$$ etamid(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*psm1 -!$$ end do -!$$ -!$$ call forecast(begchunk,psm1,& -!$$ psm1,psm1,u3,& -!$$ u3m2,u3m2,& -!$$ v3,v3m2,& -!$$ v3m2,t3,& -!$$ t3m2,t3m2,& -!$$ q3,q3m2,q3m2,dt,t_phys_frc,u_phys_frc,v_phys_frc,& -!$$ q3m2,etamid,q3m2,1) - -!!$ ! Call the main subroutine to update t, q, u, and v according to -!!$ ! large scale forcing as specified in IOP file. -!!$ call advance_iop_forcing(dt ,hvcoord ,psm1 , & ! In -!!$ u3m1 ,u3m2 ,u_phys_frc , & ! In -!!$ v3m1 ,v3m2 ,v_phys_frc , & ! In -!!$ t3m1 ,t3m2 ,t_phys_frc , & ! In -!!$ q3m1 ,q3m2 ,q_phys_frc , & ! In -!!$ u_vfcst ,v_vfcst ,t_vfcst , & ! In -!!$ q_vfcst , & ! In -!!$ u3 ,v3 ,t3 , & ! Out -!!$ q3 ) ! Out dt = get_step_size() ! Set initial profiles for current column @@ -258,20 +191,16 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) t_in(:nlev) = elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl_f) u_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl_f) v_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl_f) - -!!$ if (.not. use_3dfrc ) then -!!$ t_phys_frc(:) = 0.0_r8 -!!$ else + t_phys_frc(:) = elem(ie_scm)%derived%fT(i_scm,j_scm,:) q_phys_frc(:,:) = elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:)/dt -!!$ endif ! Call the main subroutine to update t, q, u, and v according to ! large scale forcing as specified in IOP file. call advance_iop_forcing(dt,elem(ie_scm)%state%psdry(i_scm,j_scm),& ! In u_in,v_in,t_in,stateQ_in,t_phys_frc, q_phys_frc, hvcoord, & ! In u_update,v_update,t_update,q_update) ! Out - + ! Nudge to observations if desired, for T & Q only if in SCM mode if (iop_nudge_tq ) then call advance_iop_nudging(dt,elem(ie_scm)%state%psdry(i_scm,j_scm),& ! In @@ -303,7 +232,7 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) tdiff_dyn(k) = t_update(k) - tobs(k) qdiff_dyn(k) = q_update(k,1) - qobs(k) end do - write(6,*)'tdiff=',tdiff_dyn + ! Add various diganostic outfld calls call outfld('TDIFF',tdiff_dyn,1,begchunk) call outfld('QDIFF',qdiff_dyn,1,begchunk) @@ -324,18 +253,18 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) end subroutine apply_SC_forcing !========================================================================= subroutine iop_broadcast() - + !--------------------------------------------------------- - ! Purpose: When running DP-CRM, broadcast relevant logical + ! Purpose: When running DP-CRM, broadcast relevant logical ! flags and data to all processors !---------------------------------------------------------- - + use spmd_utils, only: mpi_logical, mpi_real8, masterproc, iam, mpicom, mstrid=>masterprocid use dimensions_mod, only: nlev integer :: ierr -#ifdef SPMD - +#ifdef SPMD + call mpi_bcast(have_ps,1,mpi_logical,mstrid,mpicom,ierr) call mpi_bcast(have_tg,1,mpi_logical,mstrid,mpicom,ierr) call mpi_bcast(have_lhflx,1,mpi_logical,mstrid,mpicom,ierr) @@ -351,36 +280,36 @@ subroutine iop_broadcast() call mpi_bcast(have_divt3d,1,mpi_logical,mstrid,mpicom,ierr) call mpi_bcast(have_divq3d,1,mpi_logical,mstrid,mpicom,ierr) call mpi_bcast(use_3dfrc,1,mpi_logical,mstrid,mpicom,ierr) - + call mpi_bcast(psobs,1,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(tground,1,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(lhflxobs,1,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(shflxobs,1,mpi_real8,mstrid,mpicom,ierr) - + call mpi_bcast(tobs,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(qobs,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(uobs,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(vobs,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(cldliqobs,nlev,mpi_real8,mstrid,mpicom,ierr) - call mpi_bcast(wfld,nlev,mpi_real8,mstrid,mpicom,ierr) - + call mpi_bcast(wfld,nlev,mpi_real8,mstrid,mpicom,ierr) + call mpi_bcast(divt,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(divq,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(divt3d,nlev,mpi_real8,mstrid,mpicom,ierr) call mpi_bcast(divq3d,nlev,mpi_real8,mstrid,mpicom,ierr) - + #endif - + end subroutine iop_broadcast !========================================================================= subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) - + !--------------------------------------------------------- - ! Purpose: When running DP-CRM, broadcast relevant logical + ! Purpose: When running DP-CRM, broadcast relevant logical ! flags and data to all processors !---------------------------------------------------------- - + use dimensions_mod, only: nlev, nelemd use element_mod, only: element_t use shr_const_mod, only: pi => SHR_CONST_PI @@ -391,7 +320,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) integer, intent(out) :: ie_scm, j_scm, i_scm, indx_scm integer :: i, j, indx, ie - real(r8) :: scmposlon, minpoint, testlat, testlon, testval + real(r8) :: scmposlon, minpoint, testlat, testlon, testval integer :: ierr real(r8), parameter :: rad2deg = 180.0_r8 / pi @@ -417,15 +346,15 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) minpoint=testval if (minpoint .lt. 1.e-7) minpoint=0._r8 endif - indx=indx+1 + indx=indx+1 enddo enddo enddo - + if (ie_scm == 0 .or. i_scm == 0 .or. j_scm == 0 .or. indx_scm == 0) then call endrun('Could not find closest SCM point on input datafile') endif end subroutine scm_dyn_grid_indicies - + end module se_single_column_mod diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index e56c86cbd4..fc729c9eb4 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -21,6 +21,8 @@ module stepon use se_single_column_mod, only: scm_setfield, scm_setinitial, iop_broadcast use dyn_grid, only: hvcoord use time_manager, only: get_step_size, is_last_step, is_first_step, is_first_restart_step +use cam_history, only: outfld, write_camiop, addfld, add_default, horiz_only +use cam_history, only: write_inithist, outfld, hist_fld_active, fieldname_len implicit none private @@ -42,7 +44,6 @@ module stepon subroutine stepon_init(dyn_in, dyn_out ) - use cam_history, only: addfld, add_default, horiz_only use constituents, only: pcnst, cnst_name, cnst_longname use dimensions_mod, only: fv_nphys, cnst_name_gll, cnst_longname_gll, qsize @@ -114,7 +115,7 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & type (physics_buffer_desc), pointer :: pbuf2d(:,:) !---------------------------------------------------------------------------- - integer :: c + integer :: c class(aerosol_state), pointer :: aero_state_obj nullify(aero_state_obj) @@ -127,40 +128,32 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & ! write diagnostic fields on gll grid and initial file call diag_dynvar_ic(dyn_out%elem, dyn_out%fvm) end if - + ! Determine whether it is time for an IOP update; - ! doiopupdate set to true if model time step > next available IOP + ! doiopupdate set to true if model time step > next available IOP if (use_iop .and. masterproc) then -!!$ if (is_first_step()) then -!!$ call setiopupdate_init() -!!$ else call setiopupdate -!!$ endif end if if (single_column) then ! If first restart step then ensure that IOP data is read if (is_first_restart_step()) then - iop_update_phase1 = .false. -!jt call scm_setinitial(dyn_out%elem) -!jt if (masterproc) call readiopdata( iop_update_phase1,hvcoord ) - if (masterproc) call readiopdata( hvcoord ) - call iop_broadcast() + if (masterproc) call readiopdata( hvcoord ) + call iop_broadcast() endif - iop_update_phase1 = .true. + iop_update_phase1 = .true. if ((is_first_restart_step() .or. doiopupdate) .and. masterproc) then -!jt call readiopdata(iop_update_phase1, hvcoord) - call readiopdata(hvcoord) + call readiopdata(hvcoord) endif call iop_broadcast() call scm_setfield(dyn_out%elem,iop_update_phase1) endif - + call t_barrierf('sync_d_p_coupling', mpicom) call t_startf('d_p_coupling') ! Move data into phys_state structure. @@ -248,8 +241,7 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) use se_dyn_time_mod,only: TimeLevel_Qdp use control_mod, only: qsplit use constituents, only: pcnst, cnst_name - use cam_history, only: outfld - use time_manager, only: is_first_step + use time_manager, only: is_first_step ! arguments real(r8), intent(in) :: dtime ! Time-step @@ -260,44 +252,39 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) integer :: tl_f, tl_fQdp integer :: rc, i, j, k, p, ie -#if defined (BFB_CAM_SCAM_IOP) real(r8) :: forcing_temp(npsq,nlev), forcing_q(npsq,nlev,pcnst) real(r8) :: ftmp_temp(np,np,nlev,nelemd), ftmp_q(np,np,nlev,pcnst,nelemd), & ftmp_fq(np,np,nlev,pcnst,nelemd), ftmp_q_update(np,np,nlev,pcnst,nelemd), & ftmp_q_diff(np,np,nlev,pcnst,nelemd),ftmp_newqdp_diff(np,np,nlev,pcnst,nelemd), & ftmp_t_update(np,np,nlev,nelemd),ftmp_newt_diff(np,np,nlev,nelemd) real(r8) :: out_temp(npsq,nlev), out_q(npsq,nlev), out_u(npsq,nlev), & - out_v(npsq,nlev), out_psv(npsq) -#endif + out_v(npsq,nlev), out_psv(npsq) !-------------------------------------------------------------------------------------- call t_startf('comp_adv_tends1') tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) -#if (defined BFB_CAM_SCAM_IOP) + if (write_camiop) then + tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics - tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics - - ! Save ftmp stuff to get state before dynamics is called - do ie=1,nelemd - ftmp_temp(:,:,:,ie) = dyn_in%elem(ie)%state%T(:,:,:,tl_f) - do p = 1, qsize_d - ftmp_fq(:,:,:,p,ie)=dyn_in%elem(ie)%derived%FQ(:,:,:,p)/dtime - ftmp_q(:,:,:,p,ie) = dyn_in%elem(ie)%state%Qdp(:,:,:,p,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(:,:,:,tl_f) + ! Save ftmp stuff to get state before dynamics is called + do ie=1,nelemd + ftmp_temp(:,:,:,ie) = dyn_in%elem(ie)%state%T(:,:,:,tl_f) + do p = 1, qsize_d + ftmp_fq(:,:,:,p,ie)=dyn_in%elem(ie)%derived%FQ(:,:,:,p)/dtime + ftmp_q(:,:,:,p,ie) = dyn_in%elem(ie)%state%Qdp(:,:,:,p,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(:,:,:,tl_f) + enddo enddo - enddo -#endif + end if if (single_column) then ! Update IOP properties e.g. omega, divT, divQ - iop_update_phase1 = .false. + iop_update_phase1 = .false. if (doiopupdate) then -!jt call scm_setinitial(dyn_out%elem) -!jt if (masterproc) call readiopdata(iop_update_phase1,hvcoord) if (masterproc) call readiopdata(hvcoord) call iop_broadcast() call scm_setfield(dyn_out%elem,iop_update_phase1) @@ -321,60 +308,58 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) call t_stopf('comp_adv_tends2') - ! Update to get tendency -#if (defined BFB_CAM_SCAM_IOP) - - tl_f = TimeLevel%n0 - - do ie=1,nelemd - do k=1,nlev - do j=1,np - do i=1,np - - ! Note that this calculation will not provide b4b results with - ! an E3SM because the dynamics tendency is not computed in the exact - ! same way as an E3SM run, introducing error with roundoff - forcing_temp(i+(j-1)*np,k) = (dyn_in%elem(ie)%state%T(i,j,k,tl_f) - & - ftmp_temp(i,j,k,ie))/dtime - dyn_in%elem(ie)%derived%FT(i,j,k) - out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) - out_u(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,1,k,tl_f) - out_v(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,2,k,tl_f) - out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - out_psv(i+(j-1)*np) = dyn_in%elem(ie)%state%psdry(i,j) - - ftmp_t_update(i,j,k,ie) = ftmp_temp(i,j,k,ie) + dtime*(dyn_in%elem(ie)%derived%FT(i,j,k) + forcing_temp(i+(j-1)*np,k)) - ftmp_newt_diff(i,j,k,ie) = dyn_in%elem(ie)%state%T(i,j,k,tl_f)-ftmp_t_update(i,j,k,ie) - dyn_in%elem(ie)%state%T(i,j,k,tl_f)=ftmp_t_update(i,j,k,ie) - out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) - do p=1,qsize_d - forcing_q(i+(j-1)*np,k,p) = (dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - & - ftmp_q(i,j,k,p,ie))/dtime - ftmp_fq(i,j,k,p,ie) - ftmp_q_update(i,j,k,p,ie) = ftmp_q(i,j,k,p,ie) + dtime*(ftmp_fq(i,j,k,p,ie) + forcing_q(i+(j-1)*np,k,p)) - ftmp_newqdp_diff(i,j,k,p,ie)=dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)-(ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f)) - dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)=ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) + ! Update to get tendency + if (write_camiop) then + tl_f = TimeLevel%n0 + + do ie=1,nelemd + do k=1,nlev + do j=1,np + do i=1,np + + ! Note that this calculation will not provide b4b results with + ! an E3SM because the dynamics tendency is not computed in the exact + ! same way as an E3SM run, introducing error with roundoff + forcing_temp(i+(j-1)*np,k) = (dyn_in%elem(ie)%state%T(i,j,k,tl_f) - & + ftmp_temp(i,j,k,ie))/dtime - dyn_in%elem(ie)%derived%FT(i,j,k) + out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) + out_u(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,1,k,tl_f) + out_v(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,2,k,tl_f) + out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) + out_psv(i+(j-1)*np) = dyn_in%elem(ie)%state%psdry(i,j) + + ftmp_t_update(i,j,k,ie) = ftmp_temp(i,j,k,ie) + dtime*(dyn_in%elem(ie)%derived%FT(i,j,k) + forcing_temp(i+(j-1)*np,k)) + ftmp_newt_diff(i,j,k,ie) = dyn_in%elem(ie)%state%T(i,j,k,tl_f)-ftmp_t_update(i,j,k,ie) + dyn_in%elem(ie)%state%T(i,j,k,tl_f)=ftmp_t_update(i,j,k,ie) + out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) + do p=1,qsize_d + forcing_q(i+(j-1)*np,k,p) = (dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - & + ftmp_q(i,j,k,p,ie))/dtime - ftmp_fq(i,j,k,p,ie) + ftmp_q_update(i,j,k,p,ie) = ftmp_q(i,j,k,p,ie) + dtime*(ftmp_fq(i,j,k,p,ie) + forcing_q(i+(j-1)*np,k,p)) + ftmp_newqdp_diff(i,j,k,p,ie)=dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)-(ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f)) + dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)=ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) + enddo + out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& + dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) enddo - out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) enddo enddo + + call outfld('Ps',out_psv,npsq,ie) + call outfld('t',out_temp,npsq,ie) + call outfld('q',out_q,npsq,ie) + call outfld('u',out_u,npsq,ie) + call outfld('v',out_v,npsq,ie) + call outfld('divT3d',forcing_temp,npsq,ie) + do p=1,qsize_d + call outfld(trim(cnst_name(p))//'_dten',forcing_q(:,:,p),npsq,ie) + enddo + enddo - - call outfld('Ps',out_psv,npsq,ie) - call outfld('t',out_temp,npsq,ie) - call outfld('q',out_q,npsq,ie) - call outfld('u',out_u,npsq,ie) - call outfld('v',out_v,npsq,ie) - call outfld('divT3d',forcing_temp,npsq,ie) - do p=1,qsize_d - call outfld(trim(cnst_name(p))//'_dten',forcing_q(:,:,p),npsq,ie) - enddo - - enddo - -#endif - + end if + end subroutine stepon_run3 !========================================================================================= @@ -390,7 +375,6 @@ end subroutine stepon_final subroutine diag_dynvar_ic(elem, fvm) use constituents, only: cnst_type - use cam_history, only: write_inithist, outfld, hist_fld_active, fieldname_len use dyn_grid, only: TimeLevel use se_dyn_time_mod, only: TimeLevel_Qdp ! dynamics typestep diff --git a/src/infrastructure/phys_grid.F90 b/src/infrastructure/phys_grid.F90 index 6ca2276c61..5971a970d7 100644 --- a/src/infrastructure/phys_grid.F90 +++ b/src/infrastructure/phys_grid.F90 @@ -63,7 +63,7 @@ module phys_grid ! The identifier for the physics grid integer, parameter, public :: phys_decomp = 100 - integer, parameter, public :: phys_decomp_scm = 110 + integer, parameter, public :: phys_decomp_scm = 200 !! PUBLIC TYPES @@ -111,9 +111,6 @@ module phys_grid end interface get_lon_all_p !!XXgoldyXX: ^ temporary interface to allow old code to compile - -!jt integer, protected, public :: pver = 0 -!jt integer, protected, public :: pverp = 0 integer, protected, public :: num_global_phys_cols = 0 integer, protected, public :: columns_on_task = 0 integer, protected, public :: index_top_layer = 0 @@ -191,7 +188,7 @@ subroutine phys_grid_init() use cam_grid_support, only: horiz_coord_t, horiz_coord_create use cam_grid_support, only: cam_grid_attribute_copy, cam_grid_attr_exists use shr_const_mod, only: PI => SHR_CONST_PI - use scamMod, only: scmlon,scmlat,single_column + use scamMod, only: scmlon,scmlat,single_column,closeioplatidx,closeioplonidx ! Local variables integer :: index @@ -226,6 +223,7 @@ subroutine phys_grid_init() nullify(lonvals) nullify(latvals) nullify(grid_map) + if (single_column) nullify(grid_map_scm) nullify(lat_coord) nullify(lon_coord) nullify(area_d) @@ -312,7 +310,7 @@ subroutine phys_grid_init() ! Copy information supplied by the dycore if (single_column) then phys_columns(col_index) = dyn_columns(scm_col_index) -!jt !scm physics only has 1 global column +! !scm physics only has 1 global column phys_columns(col_index)%global_col_num = 1 phys_columns(col_index)%coord_indices(:)=scm_col_index else @@ -337,10 +335,13 @@ subroutine phys_grid_init() ! unstructured if (unstructured) then allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) + if (single_column) allocate(grid_map_scm(3, pcols * (endchunk - begchunk + 1))) else allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) + if (single_column) allocate(grid_map_scm(4, pcols * (endchunk - begchunk + 1))) end if grid_map = 0_iMap + if (single_column) grid_map_scm = 0_iMap allocate(latvals(size(grid_map, 2))) allocate(lonvals(size(grid_map, 2))) @@ -368,22 +369,29 @@ subroutine phys_grid_init() end if grid_map(1, index) = int(icol, iMap) grid_map(2, index) = int(ichnk, iMap) + if (single_column) then + grid_map_scm(1, index) = int(icol, iMap) + grid_map_scm(2, index) = int(ichnk, iMap) + end if if (icol <= ncol) then if (unstructured) then gcol = phys_columns(col_index)%global_col_num if (gcol > 0) then - grid_map(3, index) = int(gcol, iMap) + grid_map(3, index) = int(gcol, iMap) + if (single_column) grid_map_scm(3, index) = closeioplonidx end if ! else entry remains 0 else ! lon gcol = phys_columns(col_index)%coord_indices(1) if (gcol > 0) then grid_map(3, index) = int(gcol, iMap) + if (single_column) grid_map_scm(3, index) = closeioplonidx end if ! else entry remains 0 ! lat gcol = phys_columns(col_index)%coord_indices(2) if (gcol > 0) then grid_map(4, index) = gcol + if (single_column) grid_map_scm(4, index) = closeioplatidx end if ! else entry remains 0 end if end if ! Else entry remains 0 @@ -436,6 +444,8 @@ subroutine phys_grid_init() end if call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & grid_map, unstruct=unstructured, block_indexed=.true.) + if (single_column) call cam_grid_register('physgrid_scm', phys_decomp_scm, lat_coord, lon_coord, & + grid_map_scm, unstruct=unstructured, block_indexed=.true.) ! Copy required attributes from the dynamics array nullify(copy_attributes) call physgrid_copy_attributes_d(copy_gridname, copy_attributes) @@ -471,81 +481,13 @@ subroutine phys_grid_init() end if end if ! Cleanup pointers (they belong to the grid now) -!jt nullify(grid_map) ! Cleanup, we are responsible for copy attributes if (associated(copy_attributes)) then deallocate(copy_attributes) nullify(copy_attributes) end if - - ! if running single_column physgrid can map between a full grid boundary file - ! and the single column physics - To write to a single column history file - ! we need an additional grid that does not include the dynamics offset of the full grid. - if (single_column) then - ! First, create a map for the physics grid - ! It's structure will depend on whether or not the physics grid is - ! unstructured - if (unstructured) then - allocate(grid_map_scm(3, pcols * (endchunk - begchunk + 1))) - else - allocate(grid_map_scm(4, pcols * (endchunk - begchunk + 1))) - end if - ! new grid matches physgrid with the exception of file index which points to the column on the full grid - grid_map_scm = grid_map - grid_map_scm(3, 1) = int(scm_col_index, iMap) - - if (unstructured) then - ! lonvals/latvals calculated above - lon_coord => horiz_coord_create('lon', 'ncol', num_global_phys_cols, & - 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & - map=grid_map_scm(3,:)) - lat_coord => horiz_coord_create('lat', 'ncol', num_global_phys_cols, & - 'latitude', 'degrees_north', 1, size(latvals), latvals, & - map=grid_map_scm(3,:)) - else - allocate(coord_map(size(grid_map_scm, 2))) - ! We need a global minimum longitude and latitude - if (npes > 1) then - temp = lonmin - call MPI_allreduce(temp, lonmin, 1, MPI_INTEGER, MPI_MIN, & - mpicom, ierr) - temp = latmin - call MPI_allreduce(temp, latmin, 1, MPI_INTEGER, MPI_MIN, & - mpicom, ierr) - ! Create lon coord map which only writes from one of each unique lon - where(latvals == latmin) - coord_map(:) = grid_map_scm(3, :) - elsewhere - coord_map(:) = 0_iMap - end where - lon_coord => horiz_coord_create('lon', 'lon', hdim1_d, & - 'longitude', 'degrees_east', 1, size(lonvals), lonvals, & - map=coord_map) - - ! Create lat coord map which only writes from one of each unique lat - where(lonvals == lonmin) - coord_map(:) = grid_map_scm(4, :) - elsewhere - coord_map(:) = 0_iMap - end where - lat_coord => horiz_coord_create('lat', 'lat', hdim2_d, & - 'latitude', 'degrees_north', 1, size(latvals), latvals, & - map=coord_map) - deallocate(coord_map) - end if - end if - call cam_grid_register('physgrid_scm', phys_decomp_scm, lat_coord, lon_coord, & - grid_map_scm, unstruct=unstructured, block_indexed=.true.) - ! Copy required attributes from the dynamics array - nullify(copy_attributes) - call physgrid_copy_attributes_d(copy_gridname, copy_attributes) - do index = 1, size(copy_attributes) - call cam_grid_attribute_copy(copy_gridname, 'physgrid_scm', & - copy_attributes(index)) - end do - end if nullify(grid_map) - nullify(grid_map_scm) + if (single_column) nullify(grid_map_scm) deallocate(latvals) nullify(latvals) deallocate(lonvals) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 0d640295ad..18b1a7047b 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -12,7 +12,7 @@ module cam_diagnostics use physics_buffer, only: physics_buffer_desc, pbuf_add_field, dtype_r8 use physics_buffer, only: dyn_time_lvls, pbuf_get_field, pbuf_get_index, pbuf_old_tim_idx -use cam_history, only: outfld, write_inithist, hist_fld_active, inithist_all +use cam_history, only: outfld, write_inithist, hist_fld_active, inithist_all, write_camiop use cam_history_support, only: max_fieldname_len use constituents, only: pcnst, cnst_name, cnst_longname, cnst_cam_outfld use constituents, only: ptendnam, apcnst, bpcnst, cnst_get_ind @@ -221,7 +221,7 @@ subroutine diag_init_dry(pbuf2d) call register_vector_field('UAP','VAP') call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') - if (.not.dycore_is('EUL')) then + if (.not.dycore_is('EUL')) then call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') end if call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') @@ -365,7 +365,7 @@ subroutine diag_init_dry(pbuf2d) call add_default ('UAP ' , history_budget_histfile_num, ' ') call add_default ('VAP ' , history_budget_histfile_num, ' ') call add_default (apcnst(1) , history_budget_histfile_num, ' ') - if (.not.dycore_is('EUL')) then + if (.not.dycore_is('EUL')) then call add_default ('TFIX ' , history_budget_histfile_num, ' ') end if end if @@ -940,9 +940,7 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) call outfld('PHIS ',state%phis, pcols, lchnk ) -#if (defined BFB_CAM_SCAM_IOP ) - call outfld('phis ',state%phis, pcols, lchnk ) -#endif + if (write_camiop) call outfld('phis ',state%phis, pcols, lchnk ) call outfld( 'CPAIRV', cpairv(:ncol,:,lchnk), ncol, lchnk ) call outfld( 'RAIRV', rairv(:ncol,:,lchnk), ncol, lchnk ) @@ -1033,9 +1031,7 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) call outfld('OMEGA ',state%omega, pcols, lchnk ) endif -#if (defined BFB_CAM_SCAM_IOP ) - call outfld('omega ',state%omega, pcols, lchnk ) -#endif + if (write_camiop) call outfld('omega ',state%omega, pcols, lchnk ) ftem(:ncol,:) = state%omega(:ncol,:)*state%t(:ncol,:) call outfld('OMEGAT ',ftem, pcols, lchnk ) @@ -1697,9 +1693,7 @@ subroutine diag_conv(state, ztodt, pbuf) call outfld('PRECLav ', precl, pcols, lchnk ) call outfld('PRECCav ', precc, pcols, lchnk ) -#if ( defined BFB_CAM_SCAM_IOP ) - call outfld('Prec ' , prect, pcols, lchnk ) -#endif + if (write_camiop) call outfld('Prec ' , prect, pcols, lchnk ) ! Total convection tendencies. @@ -1794,13 +1788,13 @@ subroutine diag_surf (cam_in, cam_out, state, pbuf) call outfld('RHREFHT', ftem, pcols, lchnk) -#if (defined BFB_CAM_SCAM_IOP ) - call outfld('shflx ',cam_in%shf, pcols, lchnk) - call outfld('lhflx ',cam_in%lhf, pcols, lchnk) - call outfld('trefht ',cam_in%tref, pcols, lchnk) - call outfld('Tg', cam_in%ts, pcols, lchnk) - call outfld('Tsair',cam_in%ts, pcols, lchnk) -#endif + if (write_camiop) then + call outfld('shflx ',cam_in%shf, pcols, lchnk) + call outfld('lhflx ',cam_in%lhf, pcols, lchnk) + call outfld('trefht ',cam_in%tref, pcols, lchnk) + call outfld('Tg', cam_in%ts, pcols, lchnk) + call outfld('Tsair',cam_in%ts, pcols, lchnk) + end if ! ! Ouput ocn and ice fractions ! @@ -2057,7 +2051,7 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) ! Total physics tendency for Temperature ! (remove global fixer tendency from total for FV and SE dycores) - if (.not.dycore_is('EUL')) then + if (.not.dycore_is('EUL')) then call check_energy_get_integrals( heat_glob_out=heat_glob ) ftem2(:ncol) = heat_glob/cpair call outfld('TFIX', ftem2, pcols, lchnk ) diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index 0c1650e0db..e1323d8e2a 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -32,8 +32,8 @@ module check_energy use time_manager, only: is_first_step use cam_logfile, only: iulog use scamMod, only: single_column, use_camiop, heat_glob_scm - use cam_history, only: outfld - + use cam_history, only: outfld, write_camiop + implicit none private @@ -511,6 +511,7 @@ subroutine check_energy_gmean(state, pbuf2d, dtime, nstep) use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_get_chunk use physics_types, only: dyn_te_idx + use cam_history, only: write_camiop !----------------------------------------------------------------------- ! Compute global mean total energy of physics input and output states ! computed consistently with dynamical core vertical coordinate @@ -605,23 +606,21 @@ subroutine check_energy_fix(state, ptend, nstep, eshflx) if (single_column .and. use_camiop) then heat_glob = heat_glob_scm(1) endif - + ! In single column model we do NOT want to take into ! consideration the dynamics energy fixer. Since only - ! one column of dynamics is active, this data will - ! essentially be garbage. + ! one column of dynamics is active, this data will + ! essentially be garbage. if (single_column .and. .not. use_camiop) then heat_glob = 0._r8 endif ! add (-) global mean total energy difference as heating ptend%s(:ncol,:pver) = heat_glob -#if ( defined BFB_CAM_SCAM_IOP ) - if (nstep > 0) then + if (nstep > 0 .and. write_camiop) then heat_out(:ncol) = heat_glob call outfld('heat_glob', heat_out(:ncol), pcols, lchnk) endif -#endif ! compute effective sensible heat flux do i = 1, ncol @@ -882,7 +881,7 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) !----------------------------------------------------------------------- -!jt if (.not.thermo_budget_history) return + if (.not.thermo_budget_history) return do i=1,thermo_budget_num_vars name_out(i)=trim(thermo_budget_vars(i))//'_'//trim(outfld_name_suffix) @@ -945,14 +944,14 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) end if end if -!!$ call outfld(name_out(seidx) ,se , pcols ,lchnk ) -!!$ call outfld(name_out(poidx) ,po , pcols ,lchnk ) -!!$ call outfld(name_out(keidx) ,ke , pcols ,lchnk ) -!!$ call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) -!!$ call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) -!!$ call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) -!!$ call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) -!!$ call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) + call outfld(name_out(seidx) ,se , pcols ,lchnk ) + call outfld(name_out(poidx) ,po , pcols ,lchnk ) + call outfld(name_out(keidx) ,ke , pcols ,lchnk ) + call outfld(name_out(wvidx) ,wv , pcols ,lchnk ) + call outfld(name_out(wlidx) ,liq , pcols ,lchnk ) + call outfld(name_out(wiidx) ,ice , pcols ,lchnk ) + call outfld(name_out(ttidx) ,tt , pcols ,lchnk ) + call outfld(name_out(teidx) ,se+ke+po, pcols ,lchnk ) ! ! Axial angular momentum diagnostics ! @@ -966,10 +965,10 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) ! MR is equation (6) without \Delta A and sum over areas (areas are in units of radians**2) ! MO is equation (7) without \Delta A and sum over areas (areas are in units of radians**2) ! - + mr_cnst = rga*rearth**3 mo_cnst = rga*omega*rearth**4 - + mr = 0.0_r8 mo = 0.0_r8 do k = 1, pver @@ -977,14 +976,14 @@ subroutine tot_energy_phys(state, outfld_name_suffix,vc) cos_lat = cos(state%lat(i)) mr_tmp = mr_cnst*state%u(i,k)*state%pdel(i,k)*cos_lat mo_tmp = mo_cnst*state%pdel(i,k)*cos_lat**2 - + mr(i) = mr(i) + mr_tmp mo(i) = mo(i) + mo_tmp end do end do - -!!$ call outfld(name_out(mridx) ,mr, pcols,lchnk ) -!!$ call outfld(name_out(moidx) ,mo, pcols,lchnk ) + + call outfld(name_out(mridx) ,mr, pcols,lchnk ) + call outfld(name_out(moidx) ,mo, pcols,lchnk ) end subroutine tot_energy_phys diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index efb43a2ebc..2bb770c935 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -36,6 +36,7 @@ module clubb_intr use clubb_mf, only: do_clubb_mf, do_clubb_mf_diag use cloud_fraction, only: dp1, dp2 #endif + use scamMOD, only: single_column,scm_clubb_iop_name,scm_cambfb_mode implicit none #ifdef CLUBB_SGS @@ -1961,7 +1962,6 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & use time_manager, only: get_nstep, is_first_restart_step #ifdef CLUBB_SGS use hb_diff, only: pblintd - use scamMOD, only: single_column,scm_clubb_iop_name use clubb_api_module, only: & nparams, & setup_parameters_api, & @@ -2591,16 +2591,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Define the grid box size. CLUBB needs this information to determine what ! the maximum length scale should be. This depends on the column for ! variable mesh grids and lat-lon grids -!!$ if (single_column) then -!!$ ! If single column specify grid box size to be something -!!$ ! similar to a GCM run -!!$ grid_dx(:) = 100000._r8 -!!$ grid_dy(:) = 100000._r8 -!!$ else - call grid_size(state1, grid_dx, grid_dy) - -!!$ end if + call grid_size(state1, grid_dx, grid_dy) if (clubb_do_icesuper) then @@ -2899,7 +2891,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! This section of code block is NOT called in ! ! global simulations ! ! ------------------------------------------------- ! - if (single_column) then + if (single_column .and. .not. scm_cambfb_mode) then ! Initialize zo if variable ustar is used if (cam_in%landfrac(1) >= 0.5_r8) then @@ -4109,7 +4101,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & enddo enddo - if (single_column) then + if (single_column .and. .not. scm_cambfb_mode) then if (trim(scm_clubb_iop_name) == 'ATEX_48hr' .or. & trim(scm_clubb_iop_name) == 'BOMEX_5day' .or. & trim(scm_clubb_iop_name) == 'DYCOMSrf01_4day' .or. & diff --git a/src/physics/cam/convect_shallow.F90 b/src/physics/cam/convect_shallow.F90 index 0fa7e3b83d..ffe647418b 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -19,19 +19,19 @@ module convect_shallow use phys_control, only : phys_getopts implicit none - private + private save public :: & convect_shallow_register, & ! Register fields in physics buffer convect_shallow_init, & ! Initialize shallow module convect_shallow_tend, & ! Return tendencies - convect_shallow_use_shfrc ! + convect_shallow_use_shfrc ! ! The following namelist variable controls which shallow convection package is used. ! 'Hack' = Hack shallow convection (default) ! 'UW' = UW shallow convection by Sungsu Park and Christopher S. Bretherton - ! 'UNICON' = General Convection Model by Sungsu Park + ! 'UNICON' = General Convection Model by Sungsu Park ! 'off' = No shallow convection character(len=16) :: shallow_scheme ! Default set in phys_control.F90, use namelist to change @@ -40,16 +40,16 @@ module convect_shallow logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi integer :: history_budget_histfile_num ! output history file number for budget fields - ! Physics buffer indices - integer :: icwmrsh_idx = 0 - integer :: rprdsh_idx = 0 - integer :: rprdtot_idx = 0 - integer :: cldtop_idx = 0 - integer :: cldbot_idx = 0 - integer :: cush_idx = 0 + ! Physics buffer indices + integer :: icwmrsh_idx = 0 + integer :: rprdsh_idx = 0 + integer :: rprdtot_idx = 0 + integer :: cldtop_idx = 0 + integer :: cldbot_idx = 0 + integer :: cush_idx = 0 integer :: nevapr_shcu_idx = 0 - integer :: shfrc_idx = 0 - integer :: cld_idx = 0 + integer :: shfrc_idx = 0 + integer :: cld_idx = 0 integer :: concld_idx = 0 integer :: rprddp_idx = 0 integer :: tke_idx = 0 @@ -84,9 +84,9 @@ subroutine convect_shallow_register use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls use phys_control, only: use_gw_convect_sh use unicon_cam, only: unicon_cam_register - + call phys_getopts( shallow_scheme_out = shallow_scheme, microp_scheme_out = microp_scheme) - + ! SPCAM registers its own fields if (shallow_scheme == 'SPCAM') return @@ -95,7 +95,7 @@ subroutine convect_shallow_register call pbuf_add_field('RPRDTOT', 'physpkg' ,dtype_r8,(/pcols,pver/), rprdtot_idx ) call pbuf_add_field('CLDTOP', 'physpkg' ,dtype_r8,(/pcols,1/), cldtop_idx ) call pbuf_add_field('CLDBOT', 'physpkg' ,dtype_r8,(/pcols,1/), cldbot_idx ) - call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) + call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) call pbuf_add_field('NEVAPR_SHCU','physpkg' ,dtype_r8,(/pcols,pver/), nevapr_shcu_idx ) call pbuf_add_field('PREC_SH', 'physpkg' ,dtype_r8,(/pcols/), prec_sh_idx ) call pbuf_add_field('SNOW_SH', 'physpkg' ,dtype_r8,(/pcols/), snow_sh_idx ) @@ -110,16 +110,16 @@ subroutine convect_shallow_register endif ! shallow interface gbm flux_convective_cloud_rain+snow (kg/m2/s) - call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) + call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) ! shallow interface gbm flux_convective_cloud_snow (kg/m2/s) - call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) + call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) ! shallow gbm cloud liquid water (kg/kg) - call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) + call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) ! shallow gbm cloud ice water (kg/kg) - call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) + call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) ! If gravity waves from shallow convection are on, output this field. if (use_gw_convect_sh) then @@ -154,7 +154,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) use spmd_utils, only : masterproc use cam_abortutils, only : endrun use phys_control, only : cam_physpkg_is - + use physics_buffer, only : pbuf_get_index, physics_buffer_desc, pbuf_set_field real(r8), intent(in) :: pref_edge(plevp) ! Reference pressures at interfaces @@ -163,7 +163,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) integer limcnv ! Top interface level limit for convection integer k character(len=16) :: eddy_scheme - + ! SPCAM does its own convection if (shallow_scheme == 'SPCAM') return @@ -214,6 +214,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) call addfld( 'CMFMC', (/ 'ilev' /), 'A', 'kg/m2/s', 'Moist convection (deep+shallow) mass flux' ) call addfld( 'CMFSL', (/ 'ilev' /), 'A', 'W/m2', 'Moist shallow convection liquid water static energy flux' ) call addfld( 'CMFLQ', (/ 'ilev' /), 'A', 'W/m2', 'Moist shallow convection total water flux' ) + call addfld ('DQP', (/ 'lev' /), 'A', 'kg/kg/s', 'Specific humidity tendency due to precipitation' ) call addfld( 'CBMF', horiz_only, 'A', 'kg/m2/s', 'Cloud base mass flux' ) call addfld( 'CLDTOP', horiz_only, 'I', '1', 'Vertical index of cloud top' ) call addfld( 'CLDBOT', horiz_only, 'I', '1', 'Vertical index of cloud base' ) @@ -221,7 +222,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) call addfld( 'PCLDBOT', horiz_only, 'A', '1', 'Pressure of cloud base' ) call addfld( 'FREQSH', horiz_only, 'A', 'fraction', 'Fractional occurance of shallow convection' ) - + call addfld( 'HKFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of precipitation from HK convection' ) call addfld( 'HKFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of snow from HK convection' ) call addfld( 'HKNTPRPD', (/ 'lev' /), 'A', 'kg/kg/s', 'Net precipitation production from HK convection' ) @@ -286,7 +287,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) if( masterproc ) then write(iulog,*) 'MFINTI: Convection will be capped at intfc ', limcnv, ' which is ', pref_edge(limcnv), ' pascals' end if - + call mfinti( rair, cpair, gravit, latvap, rhoh2o, limcnv) ! Get args from inti.F90 case('UW') ! Park and Bretherton shallow convection scheme @@ -346,7 +347,7 @@ end function convect_shallow_use_shfrc !=============================================================================== ! subroutine convect_shallow_tend( ztodt , cmfmc , & - qc , qc2 , rliq , rliq2 , & + qc , qc2 , rliq , rliq2 , & state , ptend_all, pbuf, cam_in) use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field, pbuf_old_tim_idx @@ -357,7 +358,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & use physics_types, only : physics_ptend_dealloc use physics_types, only : physics_ptend_sum use camsrfexch, only : cam_in_t - + use constituents, only : pcnst, cnst_get_ind, cnst_get_type_byind use hk_conv, only : cmfmca use uwshcu, only : compute_uwshcu_inv @@ -381,7 +382,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8), intent(out) :: rliq2(pcols) ! Vertically-integrated reserved cloud condensate [ m/s ] real(r8), intent(out) :: qc2(pcols,pver) ! Same as qc but only from shallow convection scheme - + real(r8), intent(inout) :: cmfmc(pcols,pverp) ! Moist deep + shallow convection cloud mass flux [ kg/s/m2 ] real(r8), intent(inout) :: qc(pcols,pver) ! dq/dt due to export of cloud water into environment by shallow @@ -392,7 +393,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! --------------- ! - ! Local Variables ! + ! Local Variables ! ! --------------- ! integer :: i, k, m integer :: n, x @@ -432,7 +433,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: pcnb(pcols) ! Bottom pressure level of shallow + deep convective activity real(r8) :: cmfsl(pcols,pverp ) ! Convective flux of liquid water static energy real(r8) :: cmflq(pcols,pverp ) ! Convective flux of total water in energy unit - + real(r8) :: ftem_preCu(pcols,pver) ! Saturation vapor pressure after shallow Cu convection real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH real(r8) :: t_preCu(pcols,pver) ! Temperature after shallow Cu convection @@ -442,7 +443,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: icwmr_UW(pcols,pver) ! In-cloud Cumulus LWC [ kg/m2 ] real(r8) :: icimr_UW(pcols,pver) ! In-cloud Cumulus IWC [ kg/m2 ] real(r8) :: ptend_tracer(pcols,pver,pcnst) ! Tendencies of tracers - real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sum1, sum2, sum3, pdelx real(r8) :: landfracdum(pcols) real(r8), dimension(pcols,pver) :: sl, qt, slv @@ -476,14 +477,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & type(unicon_out_t) :: unicon_out ! ----------------------- ! - ! Main Computation Begins ! + ! Main Computation Begins ! ! ----------------------- ! zero = 0._r8 nstep = get_nstep() lchnk = state%lchnk ncol = state%ncol - + call physics_state_copy( state, state1 ) ! Copy state to local state1. ! Associate pointers with physics buffer fields @@ -553,7 +554,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & snow = 0._r8 case('Hack') ! Hack scheme - + lq(:) = .TRUE. call physics_ptend_init( ptend_loc, state%psetcols, 'cmfmca', ls=.true., lq=lq ) ! Initialize local ptend type @@ -565,7 +566,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & state%rpdel , state%zm , tpert , qpert , state%phis , & pblh , state%t , state%q , ptend_loc%s , ptend_loc%q , & cmfmc2 , rprdsh , cmfsl , cmflq , precc , & - qc2 , cnt2 , cnb2 , icwmr , rliq2 , & + qc2 , cnt2 , cnb2 , icwmr , rliq2 , & state%pmiddry, state%pdeldry, state%rpdeldry ) case('UW') ! UW shallow convection scheme @@ -576,7 +577,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! Initialize local ptend type lq(:) = .TRUE. - call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) + call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) call pbuf_get_field(pbuf, cush_idx, cush ,(/1,itim_old/), (/pcols,1/)) call pbuf_get_field(pbuf, tke_idx, tke) @@ -587,7 +588,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call pbuf_get_field(pbuf, sh_e_ed_ratio_idx, sh_e_ed_ratio) call compute_uwshcu_inv( pcols , pver , ncol , pcnst , ztodt , & - state%pint, state%zi, state%pmid , state%zm , state%pdel , & + state%pint, state%zi, state%pmid , state%zm , state%pdel , & state%u , state%v , state%q(:,:,1) , state%q(:,:,ixcldliq), state%q(:,:,ixcldice), & state%t , state%s , state%q(:,:,:) , & tke , cld , concld , pblh , cush , & @@ -606,14 +607,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! In addition, define 'icwmr' which includes both liquid and ice. ! ! --------------------------------------------------------------------- ! - icwmr(:ncol,:) = iccmr_UW(:ncol,:) + icwmr(:ncol,:) = iccmr_UW(:ncol,:) rprdsh(:ncol,:) = rprdsh(:ncol,:) + cmfdqs(:ncol,:) do m = 4, pcnst ptend_loc%q(:ncol,:pver,m) = ptend_tracer(:ncol,:pver,m) enddo ! Conservation check - + ! do i = 1, ncol ! do m = 1, pcnst ! sum1 = 0._r8 @@ -626,8 +627,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! pdelx = state%pdeldry(i,k) ! endif ! sum1 = sum1 + state%q(i,k,m)*pdelx - ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx - ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx + ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx + ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx ! enddo ! if( m .gt. 3 .and. abs(sum1) .gt. 1.e-13_r8 .and. abs(sum2-sum1)/sum1 .gt. 1.e-12_r8 ) then !! if( m .gt. 3 .and. abs(sum3) .gt. 1.e-13_r8 ) then @@ -671,7 +672,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & end select - ! --------------------------------------------------------! + ! --------------------------------------------------------! ! Calculate fractional occurance of shallow convection ! ! --------------------------------------------------------! @@ -696,7 +697,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! -------------------------------------------------------------- ! ! 'cnt2' & 'cnb2' are from shallow, 'cnt' & 'cnb' are from deep ! - ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! + ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! ! cnt2 = float(kpen) ! ! cnb2 = float(krel - 1) ! ! Note that indices decreases with height. ! @@ -707,28 +708,28 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & if( cnb2(i) > cnb(i)) cnb(i) = cnb2(i) if( cnb(i) == 1._r8 ) cnb(i) = cnt(i) pcnt(i) = state%pmid(i,int(cnt(i))) - pcnb(i) = state%pmid(i,int(cnb(i))) + pcnb(i) = state%pmid(i,int(cnb(i))) end do - + ! ----------------------------------------------- ! ! This quantity was previously known as CMFDQR. ! ! Now CMFDQR is the shallow rain production only. ! ! ----------------------------------------------- ! - + call pbuf_set_field(pbuf, rprdtot_idx, rprdsh(:ncol,:pver) + rprddp(:ncol,:pver), start=(/1,1/), kount=(/ncol,pver/)) - - ! ----------------------------------------------------------------------- ! + + ! ----------------------------------------------------------------------- ! ! Add shallow reserved cloud condensate to deep reserved cloud condensate ! ! qc [ kg/kg/s] , rliq [ m/s ] ! ! ----------------------------------------------------------------------- ! qc(:ncol,:pver) = qc(:ncol,:pver) + qc2(:ncol,:pver) - rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) + rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) ! ---------------------------------------------------------------------------- ! ! Output new partition of cloud condensate variables, as well as precipitation ! - ! ---------------------------------------------------------------------------- ! + ! ---------------------------------------------------------------------------- ! if( microp_scheme == 'MG' ) then call cnst_get_ind( 'NUMLIQ', ixnumliq ) @@ -752,12 +753,12 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'CLDTOP' , cnt , pcols , lchnk ) call outfld( 'CLDBOT' , cnb , pcols , lchnk ) call outfld( 'PCLDTOP', pcnt , pcols , lchnk ) - call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) + call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) call outfld( 'FREQSH' , freqsh , pcols , lchnk ) if( shallow_scheme .eq. 'UW' ) then call outfld( 'CBMF' , cbmf , pcols , lchnk ) - call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) + call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) call outfld( 'UWFLXSNW' , flxsnow , pcols , lchnk ) endif @@ -795,8 +796,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_pre_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_pre_Cu ', ftem_preCu , pcols, lchnk ) - ! ----------------------------------------------- ! - ! Update physics state type state1 with ptend_loc ! + ! ----------------------------------------------- ! + ! Update physics state type state1 with ptend_loc ! ! ----------------------------------------------- ! call physics_update( state1, ptend_loc, ztodt ) @@ -827,8 +828,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_aft_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_aft_Cu ', ftem , pcols, lchnk ) - tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt - rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt + tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt + rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt call outfld( 'tten_Cu ', tten , pcols, lchnk ) call outfld( 'rhten_Cu ', rhten , pcols, lchnk ) @@ -869,7 +870,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call zm_conv_evap( state1%ncol, state1%lchnk, & state1%t, state1%pmid, state1%pdel, state1%q(:pcols,:pver,1), & landfracdum, & - ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, & + ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, & ptend_loc%q(:pcols,:pver,1), & rprdsh, cld, ztodt, & precc, snow, ntprprd, ntsnprd , flxprec, flxsnow ) @@ -894,7 +895,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'HKNTSNPD' , ntsnprd , pcols, lchnk ) call outfld( 'HKEIHEAT' , ptend_loc%s , pcols, lchnk ) - ! ---------------------------------------------------------------- ! + ! ---------------------------------------------------------------- ! ! Add tendency from this process to tend from other processes here ! ! ---------------------------------------------------------------- ! diff --git a/src/physics/cam/phys_grid.F90 b/src/physics/cam/phys_grid.F90 index ca1670e4c2..e87726469f 100644 --- a/src/physics/cam/phys_grid.F90 +++ b/src/physics/cam/phys_grid.F90 @@ -111,6 +111,7 @@ module phys_grid ! The identifier for the physics grid integer, parameter, public :: phys_decomp = 100 + integer, parameter, public :: phys_decomp_scm = 200 ! dynamics field grid information integer, private :: hdim1_d, hdim2_d @@ -451,6 +452,8 @@ subroutine phys_grid_init( ) !----------------------------------------------------------------------- use mpi, only: MPI_REAL8, MPI_MAX use shr_mem_mod, only: shr_mem_getusage + use shr_scam_mod, only: shr_scam_GetCloseLatLon + use scamMod, only: closeioplonidx, closeioplatidx, single_column use pmgrid, only: plev use dycore, only: dycore_is use dyn_grid, only: get_block_bounds_d, & @@ -525,6 +528,7 @@ subroutine phys_grid_init( ) real(r8), allocatable :: latdeg_p(:) real(r8), allocatable :: londeg_p(:) integer(iMap), pointer :: grid_map(:,:) + integer(iMap), pointer :: grid_map_scm(:,:) integer(iMap), allocatable :: coord_map(:) type(horiz_coord_t), pointer :: lat_coord type(horiz_coord_t), pointer :: lon_coord @@ -540,6 +544,7 @@ subroutine phys_grid_init( ) nullify(lonvals) nullify(latvals) nullify(grid_map) + if (single_column) nullify(grid_map_scm) nullify(lat_coord) nullify(lon_coord) @@ -1105,10 +1110,13 @@ subroutine phys_grid_init( ) unstructured = dycore_is('UNSTRUCTURED') if (unstructured) then allocate(grid_map(3, pcols * (endchunk - begchunk + 1))) + if (single_column) allocate(grid_map_scm(3, pcols * (endchunk - begchunk + 1))) else allocate(grid_map(4, pcols * (endchunk - begchunk + 1))) + if (single_column) allocate(grid_map_scm(4, pcols * (endchunk - begchunk + 1))) end if grid_map = 0 + if (single_column) grid_map_scm = 0 allocate(latvals(size(grid_map, 2))) allocate(lonvals(size(grid_map, 2))) p = 0 @@ -1132,12 +1140,21 @@ subroutine phys_grid_init( ) p = p + 1 grid_map(1, p) = i grid_map(2, p) = lcid + if (single_column) then + grid_map_scm(1, p) = i + grid_map_scm(2, p) = lcid + end if if ((i <= ncols) .and. (gcols(i) > 0)) then if (unstructured) then grid_map(3, p) = gcols(i) + if (single_column) grid_map_scm(3, p) = closeioplonidx else - grid_map(3, p) = get_lon_p(lcid, i) - grid_map(4, p) = get_lat_p(lcid, i) + grid_map(3, p) = get_lon_p(lcid, i) + grid_map(4, p) = get_lat_p(lcid, i) + if (single_column) then + grid_map_scm(3, p) = closeioplonidx + grid_map_scm(4, p) = closeioplatidx + end if end if else if (i <= ncols) then @@ -1184,6 +1201,8 @@ subroutine phys_grid_init( ) end if call cam_grid_register('physgrid', phys_decomp, lat_coord, lon_coord, & grid_map, unstruct=unstructured, block_indexed=.true.) + if (single_column) call cam_grid_register('physgrid_scm', phys_decomp_scm, lat_coord, lon_coord, & + grid_map_scm, unstruct=unstructured, block_indexed=.true.) ! Copy required attributes from the dynamics array nullify(copy_attributes) call physgrid_copy_attributes_d(copy_gridname, copy_attributes) @@ -1223,6 +1242,7 @@ subroutine phys_grid_init( ) end if ! Cleanup pointers (they belong to the grid now) nullify(grid_map) + if (single_column) nullify(grid_map_scm) deallocate(latvals) nullify(latvals) deallocate(lonvals) diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index c7d5b2524b..a555fa1892 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -1086,9 +1086,7 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) use spcam_drivers, only: tphysbc_spcam use spmd_utils, only: mpicom use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate -#if (defined BFB_CAM_SCAM_IOP ) - use cam_history, only: outfld -#endif + use cam_history, only: outfld, write_camiop use cam_abortutils, only: endrun #if ( defined OFFLINE_DYN ) use metdata, only: get_met_srf1 @@ -1156,11 +1154,11 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) !----------------------------------------------------------------------- ! -#if (defined BFB_CAM_SCAM_IOP ) - do c=begchunk, endchunk - call outfld('Tg',cam_in(c)%ts,pcols ,c ) - end do -#endif + if (write_camiop) then + do c=begchunk, endchunk + call outfld('Tg',cam_in(c)%ts,pcols ,c ) + end do + end if call t_barrierf('sync_bc_physics', mpicom) call t_startf ('bc_physics') diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index 1c461c9a1c..0e1ac15f48 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -1053,9 +1053,7 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) use check_energy, only: check_energy_gmean use spmd_utils, only: mpicom use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate -#if (defined BFB_CAM_SCAM_IOP ) - use cam_history, only: outfld -#endif + use cam_history, only: outfld, write_camiop use cam_abortutils, only: endrun #if ( defined OFFLINE_DYN ) use metdata, only: get_met_srf1 @@ -1123,11 +1121,11 @@ subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) !----------------------------------------------------------------------- ! -#if (defined BFB_CAM_SCAM_IOP ) - do c=begchunk, endchunk - call outfld('Tg',cam_in(c)%ts,pcols ,c ) - end do -#endif + if (write_camiop) then + do c=begchunk, endchunk + call outfld('Tg',cam_in(c)%ts,pcols ,c ) + end do + end if call t_barrierf('sync_bc_physics', mpicom) call t_startf ('bc_physics') diff --git a/src/utils/hybvcoord_mod.F90 b/src/utils/hybvcoord_mod.F90 new file mode 100644 index 0000000000..1dbc6a33db --- /dev/null +++ b/src/utils/hybvcoord_mod.F90 @@ -0,0 +1,28 @@ +module hybvcoord_mod + use shr_kind_mod, only: r8=>shr_kind_r8 + use cam_logfile, only: iulog + use pmgrid, only: plev, plevp + use physconst, only: pstd + + implicit none + private + + !----------------------------------------------------------------------- + ! hvcoord_t: Hybrid level definitions: p = a*p0 + b*ps + ! interfaces p(k) = hyai(k)*ps0 + hybi(k)*ps + ! midpoints p(k) = hyam(k)*ps0 + hybm(k)*ps + !----------------------------------------------------------------------- + type, public :: hvcoord_t + real(r8) ps0 ! base state surface-pressure for level definitions + real(r8) hyai(plevp) ! ps0 component of hybrid coordinate - interfaces + real(r8) hyam(plev) ! ps0 component of hybrid coordinate - midpoints + real(r8) hybi(plevp) ! ps component of hybrid coordinate - interfaces + real(r8) hybm(plev) ! ps component of hybrid coordinate - midpoints + real(r8) hybd(plev) ! difference in b (hybi) across layers + real(r8) prsfac ! log pressure extrapolation factor (time, space independent) + real(r8) etam(plev) ! eta-levels at midpoints + real(r8) etai(plevp) ! eta-levels at interfaces + integer nprlev ! number of pure pressure levels at top + integer pad + end type hvcoord_t +end module hybvcoord_mod From b4ed83aa49963d1a16c7bcd1c8d702a41808b43f Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 9 Jan 2024 18:50:50 -0700 Subject: [PATCH 10/75] scam clean and updates for derecho --- src/control/cam_history.F90 | 2 - src/control/history_scam.F90 | 5 +- src/control/ncdio_atm.F90 | 47 ++---- src/control/scamMod.F90 | 19 +-- src/dynamics/eul/iop.F90 | 6 - src/dynamics/eul/tfilt_massfix.F90 | 3 - src/dynamics/se/advect_tend.F90 | 170 ++++++++++++++++++++- src/dynamics/se/dycore/prim_driver_mod.F90 | 47 ++---- src/dynamics/se/dyn_comp.F90 | 2 +- src/dynamics/se/se_single_column_mod.F90 | 31 +--- src/dynamics/se/stepon.F90 | 97 ++---------- src/infrastructure/phys_grid.F90 | 2 +- src/physics/cam/chem_surfvals.F90 | 2 + 13 files changed, 209 insertions(+), 224 deletions(-) diff --git a/src/control/cam_history.F90 b/src/control/cam_history.F90 index 484c01a705..d1f8aebef0 100644 --- a/src/control/cam_history.F90 +++ b/src/control/cam_history.F90 @@ -4805,11 +4805,9 @@ subroutine h_define (t, restart) deallocate(latvar) end if - if (write_camiop) then dtime = get_step_size() ierr = pio_put_var(tape(t)%File, tape(t)%mdtid, (/dtime/)) call cam_pio_handle_error(ierr, 'h_define: cannot put mdt') - end if ! ! Model date info ! diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index ada6460f69..7acf4858f0 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -39,8 +39,6 @@ subroutine scm_intht() !----------------------------------------------------------------------- ! Local variables ! - integer m,j ! Indices - real(r8) dummy character(len=100) dyngrid if (dycore_is('SE')) then @@ -125,7 +123,6 @@ subroutine initialize_iop_history() ! !USES: use constituents, only: pcnst, cnst_name use dycore, only: dycore_is - use phys_control, only: phys_getopts ! !ARGUMENTS: implicit none ! @@ -138,6 +135,7 @@ subroutine initialize_iop_history() ! !LOCAL VARIABLES: integer m character(len=100) dyngrid +!----------------------------------------------------------------------- if (dycore_is('SE')) then dyngrid = 'GLL' @@ -147,7 +145,6 @@ subroutine initialize_iop_history() dyngrid = 'unknown' end if -!----------------------------------------------------------------------- if (trim(dyngrid) == 'gauss_grid') then call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=trim(dyngrid)) call add_default ('CLAT1&IC',0,'I') diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90 index ce890d1876..921f3d355a 100644 --- a/src/control/ncdio_atm.F90 +++ b/src/control/ncdio_atm.F90 @@ -43,11 +43,8 @@ module ncdio_atm module procedure infld_real_3d_3d end interface - public :: infld - integer STATUS - real(r8) surfdat !----------------------------------------------------------------------- contains @@ -69,8 +66,8 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ! !USES ! - use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel - use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname + use pio, only: pio_read_darray, pio_setdebuglevel + use pio, only: PIO_MAX_NAME, pio_inq_dimname use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill ! @@ -94,7 +91,7 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ! !LOCAL VARIABLES: type(io_desc_t), pointer :: iodesc integer :: grid_id ! grid ID for data mapping - integer :: i, j ! indices + integer :: j ! indice integer :: ierr ! error status type(var_desc_t) :: varid ! variable id integer :: no_fill @@ -105,9 +102,6 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & integer :: dimlens(PIO_MAX_VAR_DIMS) ! file variable shape integer :: grid_dimlens(2) - ! Offsets for reading global variables - integer :: strt(1) = 1 ! start ncol index for netcdf 1-d - integer :: cnt (1) = 1 ! ncol count for netcdf 1-d character(len=PIO_MAX_NAME) :: tmpname character(len=128) :: errormsg @@ -115,22 +109,13 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & character(len=*), parameter :: subname='INFLD_REAL_1D_2D' ! subroutine name character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid - ! For SCAM - real(r8) :: closelat, closelon - integer :: lonidx, latidx - real(r8), pointer :: latvals_deg(:) - real(r8), pointer :: lonvals_deg(:) - real(r8), allocatable :: pos_lonvals(:) - real (r8) :: pos_scmlon,minpoint,testpoint - integer :: colidx,nvals - - nullify(iodesc) - ! !----------------------------------------------------------------------- ! ! call pio_setdebuglevel(3) + nullify(iodesc) + ! ! Error conditions ! @@ -256,7 +241,7 @@ subroutine infld_real_2d_2d(varname, ncid, dimname1, dimname2, & ! use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel - use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname + use pio, only: PIO_MAX_NAME, pio_inq_dimname use cam_pio_utils, only: cam_permute_array, calc_permutation use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill @@ -482,8 +467,7 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & ! use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel - use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname - use cam_pio_utils, only: cam_permute_array, calc_permutation + use pio, only: PIO_MAX_NAME, pio_inq_dimname use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill ! @@ -510,14 +494,11 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & ! !LOCAL VARIABLES: type(io_desc_t), pointer :: iodesc integer :: grid_id ! grid ID for data mapping - integer :: i, j, k ! indices + integer :: j ! indice integer :: ierr ! error status type(var_desc_t) :: varid ! variable id integer :: arraydimsize(3) ! field dimension lengths - integer :: arraydimids(2) ! Dimension IDs - integer :: permutation(2) - logical :: ispermuted integer :: ndims ! number of dimensions integer :: dimids(PIO_MAX_VAR_DIMS) ! file variable dims @@ -529,8 +510,6 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & integer :: cnt (3) = 1 ! ncol, lev counts for netcdf 2-d character(len=PIO_MAX_NAME) :: tmpname - real(r8), pointer :: tmp3d(:,:,:) ! input data for permutation - logical :: readvar_tmp ! if true, variable is on tape character(len=*), parameter :: subname='INFLD_REAL_2D_3D' ! subroutine name character(len=128) :: errormsg @@ -538,17 +517,13 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & character(len=PIO_MAX_NAME) :: file_dnames(3) character(len=max_hcoordname_len) :: vargridname ! Name of variable's grid - ! For SCAM - real(r8) :: closelat, closelon - integer :: lonidx, latidx - - nullify(iodesc) - ! !----------------------------------------------------------------------- ! ! call pio_setdebuglevel(3) + nullify(iodesc) + ! ! Error conditions ! @@ -680,7 +655,7 @@ subroutine infld_real_3d_3d(varname, ncid, dimname1, dimname2, dimname3, & ! use pio, only: pio_get_var, pio_read_darray, pio_setdebuglevel - use pio, only: PIO_MAX_NAME, pio_inquire, pio_inq_dimname + use pio, only: PIO_MAX_NAME, pio_inq_dimname use cam_pio_utils, only: cam_permute_array, calc_permutation use cam_pio_utils, only: cam_pio_check_var, cam_pio_inq_var_fill diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index c2ca4391a8..c00b3e4651 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -270,9 +270,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) integer :: unitn, ierr, i integer :: ncid integer :: iatt - integer :: latidx, lonidx logical :: adv - real(r8) :: ioplat,ioplon ! this list should include any variable that you might want to include in the namelist namelist /scam_nl/ iopfile, scm_iop_lhflxshflxTg, scm_iop_Tg, scm_relaxation, & @@ -429,17 +427,14 @@ subroutine readiopdata(hvcoord) integer total_levs integer u_attlen - integer nstep integer k, m integer icldliq,icldice - integer inumliq,inumice,idx - integer timeid + integer inumliq,inumice logical have_srf ! value at surface is available logical fill_ends ! logical have_cnst(pcnst) real(r8) dummy - real(r8) lat,xlat real(r8) srf(1) ! value at surface real(r8) hyam(plev),hybm(plev) real(r8) pmid(plev) ! pressure at model levels (time n) @@ -450,7 +445,7 @@ subroutine readiopdata(hvcoord) real(r8) coldata(plev) real(r8), allocatable :: dplevs( : ) integer strt4(4),cnt4(4) - character(len=16) :: lowername + integer nstep character(len=128) :: units ! Units nstep = get_nstep() @@ -1282,14 +1277,9 @@ subroutine setiopupdate !------------------------------Locals----------------------------------- - integer NCID,i - integer tsec_varID, time_dimID - integer bdate_varID - integer STATUS integer next_date, next_sec integer :: ncsec,ncdate ! current time of day,date integer :: yr, mon, day ! year, month, and day component - integer :: start_ymd,start_tod,dt !------------------------------------------------------------------------------ call get_curr_date(yr,mon,day,ncsec) @@ -1361,7 +1351,6 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) ! !----------------------------------------------------------------------- - use pmgrid, only: plev, plevp use hybvcoord_mod, only : hvcoord_t implicit none @@ -1381,7 +1370,7 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) ! ! Set interface pressures ! -!$OMP PARALLEL DO PRIVATE (K, I) +!$OMP PARALLEL DO PRIVATE (K) do k=1,nver+1 pint(k) = hvcoord%hyai(k)*hvcoord%ps0 + hvcoord%hybi(k)*ps end do @@ -1556,11 +1545,9 @@ subroutine setiopupdate_init integer bdate_varID integer STATUS integer next_date, next_sec - integer next_date_print, next_sec_print integer :: ncsec,ncdate ! current time of day,date integer :: yr, mon, day ! year, month, and day component integer :: start_ymd,start_tod - logical :: doiter !------------------------------------------------------------------------------ ! Open and read pertinent information from the IOP file diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90 index e020dbb443..245fbc4673 100644 --- a/src/dynamics/eul/iop.F90 +++ b/src/dynamics/eul/iop.F90 @@ -31,10 +31,6 @@ module iop real(r8), allocatable,target :: divv3dsav(:,:,:) real(r8), allocatable,target :: betasav(:) - integer :: closelatidx,closelonidx,latid,lonid,levid,timeid - - real(r8):: closelat,closelon - ! ! !PUBLIC MEMBER FUNCTIONS: public :: init_iop_fields @@ -109,7 +105,6 @@ subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3) ! Copy IOP forcing fields into prognostics which for Eulerian is just PS !------------------------------------------------------------------------------ use scamMod, only: tobs,uobs,vobs,qobs,psobs - use prognostics, only: ptimelevels implicit none !----------------------------------------------------------------------- @@ -119,7 +114,6 @@ subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3) real(r8), optional, intent(inout) :: u3(:,:,:,:) real(r8), optional, intent(inout) :: v3(:,:,:,:) real(r8), optional, intent(inout) :: t3(:,:,:,:) -! real(r8), optional, intent(inout) :: ps(plon,beglat:endlat,ptimelevels) real(r8), optional, intent(inout) :: ps(:,:,:) !---------------------------Local workspace----------------------------- diff --git a/src/dynamics/eul/tfilt_massfix.F90 b/src/dynamics/eul/tfilt_massfix.F90 index afe65bb2b5..0a43280a09 100644 --- a/src/dynamics/eul/tfilt_massfix.F90 +++ b/src/dynamics/eul/tfilt_massfix.F90 @@ -287,9 +287,6 @@ subroutine tfilt_massfixrun (ztodt, lat, u3m1, u3, & dqfx3(i,k,m) = dqfxcam(i,k,m) else dqfx3(i,k,m) = alpha(m)*etamid(k)*abs(qfcst(i,k,m) - qminus(i,k,m)) -!!$#if ( defined BFB_CAM_SCAM_IOP ) -!!$ dqfx3sav(i,k,m,lat) = dqfx3(i,k,m) -!!$#endif if (write_camiop) then dqfx3sav(i,k,m,lat) = dqfx3(i,k,m) endif diff --git a/src/dynamics/se/advect_tend.F90 b/src/dynamics/se/advect_tend.F90 index 44ea0ff6f7..004759f7a1 100644 --- a/src/dynamics/se/advect_tend.F90 +++ b/src/dynamics/se/advect_tend.F90 @@ -10,8 +10,14 @@ module advect_tend private public :: compute_adv_tends_xyz + public :: compute_write_iop_fields real(r8), allocatable :: adv_tendxyz(:,:,:,:,:) + real(r8), allocatable :: iop_qtendxyz(:,:,:,:,:) + real(r8), allocatable :: iop_qtendxyz_init(:,:,:,:,:) + real(r8), allocatable :: derivedfq(:,:,:,:,:) + real(r8), allocatable :: iop_ttendxyz(:,:,:,:) + real(r8), allocatable :: iop_ttendxyz_init(:,:,:,:) contains @@ -22,18 +28,18 @@ module advect_tend ! - second call computes and outputs the tendencies !---------------------------------------------------------------------- subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) - use cam_history, only: outfld, hist_fld_active + use cam_history, only: outfld use time_manager, only: get_step_size - use constituents, only: tottnam,pcnst + use constituents, only: tottnam,pcnst use dimensions_mod, only: nc,np,nlev,use_cslam use element_mod, only: element_t - use fvm_control_volume_mod, only: fvm_struct + use fvm_control_volume_mod, only: fvm_struct implicit none type (element_t), intent(in) :: elem(:) type(fvm_struct), intent(in) :: fvm(:) integer, intent(in) :: nets,nete,qn0,n0 - real(r8) :: dt,idt + real(r8) :: dt integer :: i,j,ic,nx,ie logical :: init real(r8), allocatable, dimension(:,:) :: ftmp @@ -44,7 +50,7 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) nx=np endif allocate( ftmp(nx*nx,nlev) ) - + init = .false. if ( .not. allocated( adv_tendxyz ) ) then init = .true. @@ -68,7 +74,6 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) if ( .not. init ) then dt = get_step_size() - idt = 1._r8/dt do ie=nets,nete do ic = 1,pcnst @@ -85,4 +90,157 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) deallocate(ftmp) end subroutine compute_adv_tends_xyz + !---------------------------------------------------------------------- + ! computes camiop specific tendencies and + ! and writes these to the camiop file + ! called twice each time step: + ! - first call sets the initial mixing ratios/state + ! - second call computes and outputs the tendencies + !---------------------------------------------------------------------- + subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) + use cam_history, only: outfld, hist_fld_active + use time_manager, only: get_step_size + use constituents, only: pcnst,cnst_name + use dimensions_mod, only: nc,np,nlev,use_cslam,npsq + use element_mod, only: element_t + use fvm_control_volume_mod, only: fvm_struct + implicit none + + type (element_t), intent(inout) :: elem(:) + type(fvm_struct), intent(inout) :: fvm(:) + integer, intent(in) :: nets,nete,qn0,n0 + real(r8) :: dt + real(r8), allocatable :: q_new(:,:,:) + real(r8), allocatable :: q_adv(:,:,:) + real(r8), allocatable :: t_adv(:,:) + real(r8), allocatable :: out_q(:,:) + real(r8), allocatable :: out_t(:,:) + real(r8), allocatable :: out_u(:,:) + real(r8), allocatable :: out_v(:,:) + real(r8), allocatable :: out_ps(:) + + integer :: i,j,ic,nx,ie,nxsq,p + logical :: init + !---------------------------------------------------------------------------- + + if (use_cslam) then + nx=nc + else + nx=np + endif + nxsq=nx*nx + + init = .false. + dt = get_step_size() + + if ( .not. allocated( iop_qtendxyz ) ) then + init = .true. + + allocate( iop_qtendxyz(nx,nx,nlev,pcnst,nets:nete) ) + iop_qtendxyz = 0._r8 + allocate( derivedfq(nx,nx,nlev,pcnst,nets:nete) ) + derivedfq = 0._r8 + allocate( iop_qtendxyz_init(nx,nx,nlev,pcnst,nets:nete) ) + iop_qtendxyz_init = 0._r8 + allocate( iop_ttendxyz(nx,nx,nlev,nets:nete) ) + iop_ttendxyz = 0._r8 + allocate( iop_ttendxyz_init(nx,nx,nlev,nets:nete) ) + iop_ttendxyz_init = 0._r8 + endif + + ! save inital/calc tendencies on second call to this routine. + if (use_cslam) then + do ie=nets,nete + do ic=1,pcnst + iop_qtendxyz(:,:,:,ic,ie) = fvm(ie)%c(1:nc,1:nc,:,ic) - iop_qtendxyz(:,:,:,ic,ie) + end do + end do + else + do ie=nets,nete + do ic=1,pcnst + iop_qtendxyz(:,:,:,ic,ie) = elem(ie)%state%Qdp(:,:,:,ic,qn0)/elem(ie)%state%dp3d(:,:,:,n0) - iop_qtendxyz(:,:,:,ic,ie) + enddo + end do + end if + do ie=nets,nete + iop_ttendxyz(:,:,:,ie) = elem(ie)%state%T(:,:,:,n0) - iop_ttendxyz(:,:,:,ie) + end do + + if (init) then + do ie=nets,nete + iop_ttendxyz_init(:,:,:,ie) = iop_ttendxyz(:,:,:,ie) + iop_qtendxyz_init(:,:,:,:,ie) = iop_qtendxyz(:,:,:,:,ie) + derivedfq(:,:,:,:,ie)=elem(ie)%derived%FQ(:,:,:,:)/dt + end do + end if + + if ( .not. init ) then + allocate( q_adv(nxsq,nlev,pcnst) ) + q_adv = 0._r8 + allocate( t_adv(npsq,nlev) ) + t_adv = 0._r8 + allocate( q_new(nx,nx,nlev) ) + q_new = 0._r8 + allocate( out_q(npsq,nlev) ) + out_q = 0._r8 + allocate( out_t(npsq,nlev) ) + out_t = 0._r8 + allocate( out_u(npsq,nlev) ) + out_u = 0._r8 + allocate( out_v(npsq,nlev) ) + out_v = 0._r8 + allocate( out_ps(npsq) ) + out_ps = 0._r8 + do ie=nets,nete + do j=1,nx + do i=1,nx + t_adv(i+(j-1)*np,:) = iop_ttendxyz(i,j,:,ie)/dt - elem(ie)%derived%FT(i,j,:) + out_u(i+(j-1)*np,:) = elem(ie)%state%v(i,j,1,:,n0) + out_v(i+(j-1)*np,:) = elem(ie)%state%v(i,j,2,:,n0) + out_ps(i+(j-1)*np) = elem(ie)%state%psdry(i,j) + + ! to retain bfb for scam check, replace state q and t with roundoff version calculated using the ordering and tendencies of the + ! scam prognostic equation + elem(ie)%state%T(i,j,:,n0) = iop_ttendxyz_init(i,j,:,ie) + dt*(elem(ie)%derived%FT(i,j,:) + t_adv(i+(j-1)*np,:)) + out_t(i+(j-1)*np,:) = elem(ie)%state%T(i,j,:,n0) + do p=1,pcnst + q_adv(i+(j-1)*nx,:,p) = iop_qtendxyz(i,j,:,p,ie)/dt - derivedfq(i,j,:,p,ie) + q_new(i,j,:) = iop_qtendxyz_init(i,j,:,p,ie) + dt*(derivedfq(i,j,:,p,ie) + q_adv(i+(j-1)*nx,:,p)) + if (use_cslam) then + fvm(ie)%c(i,j,:,p)=q_new(i,j,:) + else + elem(ie)%state%Qdp(i,j,:,p,qn0)=q_new(i,j,:)*elem(ie)%state%dp3d(i,j,:,n0) + end if + enddo + out_q(i+(j-1)*nx,:) = elem(ie)%state%Qdp(i,j,:,1,qn0)/elem(ie)%state%dp3d(i,j,:,n0) + end do + end do + call outfld('Ps',out_ps,npsq,ie) + call outfld('t',out_t,npsq,ie) + call outfld('q',out_q,nxsq,ie) + call outfld('u',out_u,npsq,ie) + call outfld('v',out_v,npsq,ie) + call outfld('divT3d',t_adv,npsq,ie) + do p=1,pcnst + call outfld(trim(cnst_name(p))//'_dten',q_adv(:,:,p),nxsq,ie) + enddo + end do + + deallocate(iop_ttendxyz) + deallocate(iop_ttendxyz_init) + deallocate(iop_qtendxyz) + deallocate(iop_qtendxyz_init) + deallocate(derivedfq) + deallocate(out_t) + deallocate(out_q) + deallocate(out_u) + deallocate(out_v) + deallocate(out_ps) + deallocate(t_adv) + deallocate(q_adv) + deallocate(q_new) + + endif + end subroutine compute_write_iop_fields + end module advect_tend diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index fc11b3b93f..6750d5dee9 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -644,20 +644,8 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) use hybvcoord_mod, only: hvcoord_t use se_dyn_time_mod, only: TimeLevel_t, timelevel_update use control_mod, only: statefreq, qsplit, nu_p - use thread_mod, only: omp_get_thread_num - use prim_advance_mod, only: prim_advance_exp - use prim_advection_mod, only: prim_advec_tracers_remap, prim_advec_tracers_fvm, deriv - use derivative_mod, only: subcell_integration - use hybrid_mod, only: set_region_num_threads, config_thread_region, get_loop_ranges - use dimensions_mod, only: use_cslam,fvm_supercycling,fvm_supercycling_jet - use dimensions_mod, only: kmin_jet, kmax_jet - use fvm_mod, only: ghostBufQnhc_vh,ghostBufQ1_vh, ghostBufFlux_vh - use fvm_mod, only: ghostBufQ1_h,ghostBufQnhcJet_h, ghostBufFluxJet_h - -#ifdef waccm_debug - use cam_history, only: outfld -#endif - + use prim_advection_mod, only: deriv + use hybrid_mod, only: config_thread_region, get_loop_ranges type (element_t) , intent(inout) :: elem(:) type(fvm_struct), intent(inout) :: fvm(:) @@ -669,19 +657,7 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) type (TimeLevel_t), intent(inout) :: tl integer, intent(in) :: rstep ! vertical remap subcycling step - type (hybrid_t):: hybridnew,hybridnew2 - real(kind=r8) :: st, st1, dp - integer :: ie,t,q,k,i,j,n, n_Q - integer :: ithr - integer :: region_num_threads - integer :: kbeg,kend - - real (kind=r8) :: tempdp3d(np,np), x - real (kind=r8) :: tempmass(nc,nc) - real (kind=r8) :: tempflux(nc,nc,4) - - real (kind=r8) :: dp_np1(np,np) - + integer :: ie,n ! =============== ! initialize mean flux accumulation variables and save some variables at n0 @@ -700,22 +676,22 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) ! Dynamical Step ! =============== - call t_startf('prim_advance_exp') + call t_startf('set_prescribed_scm') call set_prescribed_scm(elem, fvm, deriv, hvcoord, & hybrid, dt, tl, nets, nete) - call t_stopf('prim_advance_exp') + call t_stopf('set_prescribed_scm') do n=2,qsplit call TimeLevel_update(tl,"leapfrog") - call t_startf('prim_advance_exp') + call t_startf('set_prescribed_scm') call set_prescribed_scm(elem, fvm, deriv, hvcoord, & hybrid, dt, tl, nets, nete) - call t_stopf('prim_advance_exp') + call t_stopf('set_prescribed_scm') enddo end subroutine prim_step_scm @@ -831,12 +807,8 @@ subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & use element_mod, only: element_t use hybvcoord_mod, only: hvcoord_t use hybrid_mod, only: hybrid_t - use se_dyn_time_mod, only: TimeLevel_t, timelevel_qdp, tevolve + use se_dyn_time_mod, only: TimeLevel_t, timelevel_qdp use fvm_control_volume_mod, only: fvm_struct - use cam_thermo, only: get_kappa_dry - use air_composition, only: thermodynamic_active_species_num - use air_composition, only: thermodynamic_active_species_idx_dycore, get_cp - use physconst, only: cpair implicit none type (element_t), intent(inout), target :: elem(:) @@ -850,11 +822,10 @@ subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & integer , intent(in) :: nete ! Local - integer :: ie,nm1,n0,np1,k,qn0,qnp1,m_cnst, nq,p + integer :: ie,nm1,n0,np1,k,qn0,qnp1,p real(kind=r8) :: eta_dot_dpdn(np,np,nlev+1) - call t_startf('prim_advance_exp') nm1 = tl%nm1 n0 = tl%n0 np1 = tl%np1 diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 9a5d684c87..59be97d1e4 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -1151,7 +1151,7 @@ subroutine dyn_run(dyn_state) end if ! not use_3dfrc if (single_column) then - call apply_SC_forcing(dyn_state%elem,hvcoord,TimeLevel,3,.false.,nets,nete) + call apply_SC_forcing(dyn_state%elem,hvcoord,TimeLevel,3,.false.) end if ! output vars on CSLAM fvm grid diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 9f916a7c9e..df3197c507 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -13,7 +13,7 @@ module se_single_column_mod have_omega, have_cldliq, have_divt, have_divq, have_divt3d, have_divq3d, & use_3dfrc,scmlat,scmlon use constituents, only: cnst_get_ind, pcnst -use dimensions_mod, only: nelemd, np, nlev +use dimensions_mod, only: nelemd, np, nlev, qsize use time_manager, only: get_nstep, is_first_step, get_step_size, is_first_restart_step use ppgrid, only: begchunk use se_dyn_time_mod, only: timelevel_qdp @@ -40,7 +40,6 @@ module se_single_column_mod subroutine scm_setinitial(elem) - use constituents, only: qmin use dyn_grid, only: TimeLevel use control_mod, only: qsplit @@ -48,7 +47,7 @@ subroutine scm_setinitial(elem) type(element_t), intent(inout) :: elem(:) - integer i, j, k, cix, ie + integer k integer inumliq, inumice, icldliq, icldice integer :: tl_f, tl_fqdp @@ -122,7 +121,7 @@ subroutine scm_setfield(elem,iop_update_phase1) logical, intent(in) :: iop_update_phase1 type(element_t), intent(inout) :: elem(:) - integer i, j, k, ie + integer :: k integer :: tl_f, tl_fqdp tl_f = timelevel%n0 @@ -142,34 +141,23 @@ subroutine scm_setfield(elem,iop_update_phase1) end subroutine scm_setfield -subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) +subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance) ! use scamMod, only: single_column, use_3dfrc - use dimensions_mod, only: np, nlev, npsq,qsize_d use hybvcoord_mod, only: hvcoord_t - use element_mod, only: element_t - use physconst, only: rair use se_dyn_time_mod,only: TimeLevel_t - use time_manager, only: get_nstep use control_mod, only: qsplit use apply_iop_forcing_mod, only:advance_iop_forcing, advance_iop_nudging - use ppgrid, only:begchunk type (element_t), intent(inout), target :: elem(:) type (hvcoord_t), intent(in) :: hvcoord type (TimeLevel_t), intent(in) :: tl logical, intent(in) :: t_before_advance - integer, intent(in) :: n,nets,nete + integer, intent(in) :: n - integer :: tl_qdp_np0,tl_qdp_np1 - integer :: ie,k,i,j,t,m - real (r8), dimension(nlev) :: p + integer :: k, m real (r8) :: dt - - integer :: nelemd_todo, np_todo - logical :: scm_multcols = .false. logical :: iop_nudge_tq = .false. - real (r8), dimension(nlev,pcnst) :: stateQ_in, q_update, q_phys_frc real (r8), dimension(nlev) :: t_phys_frc, t_update, u_update, v_update real (r8), dimension(nlev) :: t_in, u_in, v_in @@ -193,7 +181,7 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance,nets,nete) v_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,2,:nlev,tl_f) t_phys_frc(:) = elem(ie_scm)%derived%fT(i_scm,j_scm,:) - q_phys_frc(:,:) = elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:)/dt + q_phys_frc(:,:qsize) = elem(ie_scm)%derived%fQ(i_scm,j_scm,:,:qsize)/dt ! Call the main subroutine to update t, q, u, and v according to ! large scale forcing as specified in IOP file. @@ -260,7 +248,6 @@ subroutine iop_broadcast() !---------------------------------------------------------- use spmd_utils, only: mpi_logical, mpi_real8, masterproc, iam, mpicom, mstrid=>masterprocid - use dimensions_mod, only: nlev integer :: ierr #ifdef SPMD @@ -310,8 +297,6 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) ! flags and data to all processors !---------------------------------------------------------- - use dimensions_mod, only: nlev, nelemd - use element_mod, only: element_t use shr_const_mod, only: pi => SHR_CONST_PI use cam_abortutils, only: endrun @@ -344,7 +329,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) i_scm=i j_scm=j minpoint=testval - if (minpoint .lt. 1.e-7) minpoint=0._r8 + if (minpoint .lt. 1.e-7_r8) minpoint=0._r8 endif indx=indx+1 enddo diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index fc729c9eb4..7a9fd2f58e 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -11,18 +11,18 @@ module stepon use cam_abortutils, only: endrun use parallel_mod, only: par -use dimensions_mod, only: np, npsq, nlev, qsize_d, nelemd +use dimensions_mod, only: np, npsq, nlev, nelemd use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state use microp_aero, only: aerosol_state_object, aerosol_properties_object use scamMod, only: use_iop, doiopupdate, single_column, & - setiopupdate, setiopupdate_init, readiopdata -use se_single_column_mod, only: scm_setfield, scm_setinitial, iop_broadcast + setiopupdate, readiopdata +use se_single_column_mod, only: scm_setfield, iop_broadcast use dyn_grid, only: hvcoord -use time_manager, only: get_step_size, is_last_step, is_first_step, is_first_restart_step +use time_manager, only: get_step_size, is_first_restart_step use cam_history, only: outfld, write_camiop, addfld, add_default, horiz_only -use cam_history, only: write_inithist, outfld, hist_fld_active, fieldname_len +use cam_history, only: write_inithist, hist_fld_active, fieldname_len implicit none private @@ -236,12 +236,11 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) use camsrfexch, only: cam_out_t use dyn_comp, only: dyn_run - use advect_tend, only: compute_adv_tends_xyz + use advect_tend, only: compute_adv_tends_xyz, compute_write_iop_fields use dyn_grid, only: TimeLevel use se_dyn_time_mod,only: TimeLevel_Qdp use control_mod, only: qsplit use constituents, only: pcnst, cnst_name - use time_manager, only: is_first_step ! arguments real(r8), intent(in) :: dtime ! Time-step @@ -251,38 +250,10 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) type (dyn_export_t), intent(inout) :: dyn_out ! Dynamics export container integer :: tl_f, tl_fQdp - integer :: rc, i, j, k, p, ie - real(r8) :: forcing_temp(npsq,nlev), forcing_q(npsq,nlev,pcnst) - real(r8) :: ftmp_temp(np,np,nlev,nelemd), ftmp_q(np,np,nlev,pcnst,nelemd), & - ftmp_fq(np,np,nlev,pcnst,nelemd), ftmp_q_update(np,np,nlev,pcnst,nelemd), & - ftmp_q_diff(np,np,nlev,pcnst,nelemd),ftmp_newqdp_diff(np,np,nlev,pcnst,nelemd), & - ftmp_t_update(np,np,nlev,nelemd),ftmp_newt_diff(np,np,nlev,nelemd) - real(r8) :: out_temp(npsq,nlev), out_q(npsq,nlev), out_u(npsq,nlev), & - out_v(npsq,nlev), out_psv(npsq) !-------------------------------------------------------------------------------------- - call t_startf('comp_adv_tends1') - tl_f = TimeLevel%n0 - call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) - - if (write_camiop) then - tl_f = TimeLevel%n0 ! timelevel which was adjusted by physics - - ! Save ftmp stuff to get state before dynamics is called - do ie=1,nelemd - ftmp_temp(:,:,:,ie) = dyn_in%elem(ie)%state%T(:,:,:,tl_f) - do p = 1, qsize_d - ftmp_fq(:,:,:,p,ie)=dyn_in%elem(ie)%derived%FQ(:,:,:,p)/dtime - ftmp_q(:,:,:,p,ie) = dyn_in%elem(ie)%state%Qdp(:,:,:,p,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(:,:,:,tl_f) - enddo - enddo - end if - if (single_column) then - - ! Update IOP properties e.g. omega, divT, divQ - + ! Update IOP properties e.g. omega, divT, divQ iop_update_phase1 = .false. if (doiopupdate) then if (masterproc) call readiopdata(hvcoord) @@ -295,6 +266,7 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) + if (write_camiop) call compute_write_iop_fields(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) call t_stopf('comp_adv_tends1') call t_barrierf('sync_dyn_run', mpicom) @@ -306,60 +278,9 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) tl_f = TimeLevel%n0 call TimeLevel_Qdp(TimeLevel, qsplit, tl_fQdp) call compute_adv_tends_xyz(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) + if (write_camiop) call compute_write_iop_fields(dyn_in%elem,dyn_in%fvm,1,nelemd,tl_fQdp,tl_f) call t_stopf('comp_adv_tends2') - ! Update to get tendency - if (write_camiop) then - tl_f = TimeLevel%n0 - - do ie=1,nelemd - do k=1,nlev - do j=1,np - do i=1,np - - ! Note that this calculation will not provide b4b results with - ! an E3SM because the dynamics tendency is not computed in the exact - ! same way as an E3SM run, introducing error with roundoff - forcing_temp(i+(j-1)*np,k) = (dyn_in%elem(ie)%state%T(i,j,k,tl_f) - & - ftmp_temp(i,j,k,ie))/dtime - dyn_in%elem(ie)%derived%FT(i,j,k) - out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) - out_u(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,1,k,tl_f) - out_v(i+(j-1)*np,k) = dyn_in%elem(ie)%state%v(i,j,2,k,tl_f) - out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - out_psv(i+(j-1)*np) = dyn_in%elem(ie)%state%psdry(i,j) - - ftmp_t_update(i,j,k,ie) = ftmp_temp(i,j,k,ie) + dtime*(dyn_in%elem(ie)%derived%FT(i,j,k) + forcing_temp(i+(j-1)*np,k)) - ftmp_newt_diff(i,j,k,ie) = dyn_in%elem(ie)%state%T(i,j,k,tl_f)-ftmp_t_update(i,j,k,ie) - dyn_in%elem(ie)%state%T(i,j,k,tl_f)=ftmp_t_update(i,j,k,ie) - out_temp(i+(j-1)*np,k) = dyn_in%elem(ie)%state%T(i,j,k,tl_f) - do p=1,qsize_d - forcing_q(i+(j-1)*np,k,p) = (dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - & - ftmp_q(i,j,k,p,ie))/dtime - ftmp_fq(i,j,k,p,ie) - ftmp_q_update(i,j,k,p,ie) = ftmp_q(i,j,k,p,ie) + dtime*(ftmp_fq(i,j,k,p,ie) + forcing_q(i+(j-1)*np,k,p)) - ftmp_newqdp_diff(i,j,k,p,ie)=dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)-(ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f)) - dyn_in%elem(ie)%state%Qdp(i,j,k,p,tl_fQdp)=ftmp_q_update(i,j,k,p,ie)*dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - enddo - out_q(i+(j-1)*np,k) = dyn_in%elem(ie)%state%Qdp(i,j,k,1,tl_fQdp)/& - dyn_in%elem(ie)%state%dp3d(i,j,k,tl_f) - enddo - enddo - enddo - - call outfld('Ps',out_psv,npsq,ie) - call outfld('t',out_temp,npsq,ie) - call outfld('q',out_q,npsq,ie) - call outfld('u',out_u,npsq,ie) - call outfld('v',out_v,npsq,ie) - call outfld('divT3d',forcing_temp,npsq,ie) - do p=1,qsize_d - call outfld(trim(cnst_name(p))//'_dten',forcing_q(:,:,p),npsq,ie) - enddo - - enddo - end if - end subroutine stepon_run3 !========================================================================================= diff --git a/src/infrastructure/phys_grid.F90 b/src/infrastructure/phys_grid.F90 index 5971a970d7..0bc2b6f8e6 100644 --- a/src/infrastructure/phys_grid.F90 +++ b/src/infrastructure/phys_grid.F90 @@ -253,7 +253,7 @@ subroutine phys_grid_init() pos_scmlon = mod(scmlon + 360._r8,360._r8) if (unstructured) then - minpoint=1000.0 + minpoint=1000.0_r8 do i=1,columns_on_task testpoint=abs(pos_dynlons(i)-pos_scmlon)+abs(dynlats(i)-scmlat) if (testpoint .lt. minpoint) then diff --git a/src/physics/cam/chem_surfvals.F90 b/src/physics/cam/chem_surfvals.F90 index 6191c3a595..84af83b71a 100644 --- a/src/physics/cam/chem_surfvals.F90 +++ b/src/physics/cam/chem_surfvals.F90 @@ -264,6 +264,7 @@ subroutine chem_surfvals_init() use infnan, only: posinf, assignment(=) use mo_flbc, only: flbc_inti use phys_control, only: use_simple_phys + !---------------------------Local variables----------------------------- integer :: yr, mon, day, ncsec character(len=*), parameter :: sub = 'chem_surfvals_init' @@ -327,6 +328,7 @@ subroutine chem_surfvals_init() ! set by lower boundary conditions file call flbc_inti( flbc_file, flbc_list, flbc_timing, co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) call chem_surfvals_set() + endif if (masterproc) then From b567e510080321e4d0d9e71401e83bcb7ca7d9c8 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sat, 20 Jan 2024 22:32:02 -0700 Subject: [PATCH 11/75] bug fix for iopTimeIdx when iop step size is smaller than model timestep --- src/control/scamMod.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index c00b3e4651..aaf7fc2d86 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -1297,8 +1297,12 @@ subroutine setiopupdate call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) if ( ncdate > next_date .or. (ncdate == next_date & .and. ncsec >= next_sec)) then - iopTimeIdx = iopTimeIdx + 1 doiopupdate = .true. + ! check to see if we need to move iopindex ahead more than 1 step + do while ( ncdate > next_date .or. (ncdate == next_date .and. ncsec >= next_sec)) + iopTimeIdx = iopTimeIdx + 1 + call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(iopTimeIdx+1)) + end do #if DEBUG > 2 if (masterproc) write(iulog,*) sub//'nstep = ',get_nstep() if (masterproc) write(iulog,*) sub//'ncdate=',ncdate,' ncsec=',ncsec From e7d33d75b934b181b596da0c6d97440886a233b4 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 21 Jan 2024 20:54:52 -0700 Subject: [PATCH 12/75] PR updates for Cheryl and Jim --- Externals.cfg | 2 +- bld/namelist_files/namelist_defaults_cam.xml | 2 - cime_config/config_pes.xml | 66 +++---- src/control/history_scam.F90 | 62 +++---- src/control/ncdio_atm.F90 | 4 +- src/control/scamMod.F90 | 173 +++++++++---------- src/dynamics/eul/dyn_comp.F90 | 7 +- src/dynamics/se/apply_iop_forcing.F90 | 2 +- 8 files changed, 155 insertions(+), 163 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index dd15eece30..0a81de5eec 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -43,7 +43,7 @@ local_path = components/cpl7 required = True [share] -tag = share1.0.17 +tag = share1.0.17_scamdev protocol = git repo_url = https://github.com/jtruesdal/CESM_share local_path = share diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index b56650626c..cb5eb84f39 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -316,7 +316,6 @@ atm/cam/topo/se/ne240pg2_nc3000_Co008_Fi001_PF_nullRR_Nsw005_20171014.nc atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc atm/cam/topo/se/ne3pg3_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230209.nc -atm/cam/topo/USGS-gtopo30_ne4np4_16x.c20160612.nc atm/cam/topo/se/ne5pg3_nc3000_Co360_Fi001_MulG_PF_nullRR_Nsw064_20170516.nc atm/cam/topo/se/ne16pg3_nc3000_Co120_Fi001_PF_nullRR_Nsw084_20171012.nc atm/cam/topo/se/ne30pg3_gmted2010_modis_bedmachine_nc3000_Laplace0100_20230105.nc @@ -1898,7 +1897,6 @@ atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc atm/cam/chem/trop_mam/atmsrf_ne3np4.pg3_221214.nc -atm/cam/chem/trop_mam/atmsrf_ne4np4_from_0.23x0.31_181018.nc atm/cam/chem/trop_mam/atmsrf_ne5np4_110920.nc atm/cam/chem/trop_mam/atmsrf_ne5pg3_201105.nc atm/cam/chem/trop_mam/atmsrf_ne16np4_110920.nc diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index 1b52b2be50..85da4d41ea 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -4,39 +4,6 @@ - - none - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - none @@ -1982,6 +1949,39 @@ 1 + + none + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index 7acf4858f0..b1727e01ce 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -118,23 +118,25 @@ subroutine scm_intht() end subroutine scm_intht !####################################################################### subroutine initialize_iop_history() +!----------------------------------------------------------------------- +! +! Purpose: Add fields and set defaults for SCAM CAM BFB IOP initial file +! as well as single column output history +! +! Method: Call a subroutine to add each field +! +!----------------------------------------------------------------------- ! -! !DESCRIPTION: ! !USES: use constituents, only: pcnst, cnst_name use dycore, only: dycore_is ! !ARGUMENTS: implicit none -! -! !CALLED FROM: -! -! !REVISION HISTORY: -! -!EOP -! + ! !LOCAL VARIABLES: integer m character(len=100) dyngrid + !----------------------------------------------------------------------- if (dycore_is('SE')) then @@ -146,22 +148,22 @@ subroutine initialize_iop_history() end if if (trim(dyngrid) == 'gauss_grid') then - call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=trim(dyngrid)) - call add_default ('CLAT1&IC',0,'I') - call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname=trim(dyngrid)) - call add_default ('CLON1&IC',0,'I') - call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname=trim(dyngrid)) - call add_default ('PHI&IC',0, 'I') - call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname=trim(dyngrid)) - call add_default ('LAM&IC',0, 'I') - - call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname=trim(dyngrid)) - call add_default ('CLAT',2,' ') - - call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) - call add_default ('fixmas',2,' ') - call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) - call add_default ('beta',2,' ') + call addfld ('CLAT1&IC', horiz_only, 'I', ' ','cos lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLAT1&IC',0,'I') + call addfld ('CLON1&IC', horiz_only, 'I', ' ','cos lon for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLON1&IC',0,'I') + call addfld ('PHI&IC', horiz_only, 'I', ' ','lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('PHI&IC',0, 'I') + call addfld ('LAM&IC', horiz_only, 'I', ' ','lon for bfb testing', gridname=trim(dyngrid)) + call add_default ('LAM&IC',0, 'I') + + call addfld ('CLAT', horiz_only, 'A', ' ', 'cos lat for bfb testing', gridname=trim(dyngrid)) + call add_default ('CLAT',2,' ') + + call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) + call add_default ('fixmas',2,' ') + call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(dyngrid)) + call add_default ('beta',2,' ') end if call addfld ('q', (/ 'lev' /), 'A', 'kg/kg', 'Q for scam',gridname=trim(dyngrid)) @@ -189,12 +191,12 @@ subroutine initialize_iop_history() trim(cnst_name(m))//' IOP Dynamics Residual for '//trim(cnst_name(m)),gridname=trim(dyngrid)) call add_default (trim(cnst_name(m))//'_dten',2,' ') if (trim(dyngrid) == 'gauss_grid') then - call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & - gridname=trim(dyngrid)) - call add_default (trim(cnst_name(m))//'_alph',2,' ') - call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & - gridname=trim(dyngrid)) - call add_default (trim(cnst_name(m))//'_dqfx',2,' ') + call addfld (trim(cnst_name(m))//'_alph', horiz_only, 'A', 'kg/kg',trim(cnst_name(m))//' alpha constituent fixer', & + gridname=trim(dyngrid)) + call add_default (trim(cnst_name(m))//'_alph',2,' ') + call addfld (trim(cnst_name(m))//'_dqfx', (/ 'lev' /), 'A', 'kg/kg',trim(cnst_name(m))//' dqfx3 fixer', & + gridname=trim(dyngrid)) + call add_default (trim(cnst_name(m))//'_dqfx',2,' ') end if end do call addfld ('shflx', horiz_only, 'A', 'W/m2', 'Surface sensible heat flux for scam',gridname='physgrid') diff --git a/src/control/ncdio_atm.F90 b/src/control/ncdio_atm.F90 index 921f3d355a..f727fc8f25 100644 --- a/src/control/ncdio_atm.F90 +++ b/src/control/ncdio_atm.F90 @@ -91,7 +91,7 @@ subroutine infld_real_1d_2d(varname, ncid, dimname1, & ! !LOCAL VARIABLES: type(io_desc_t), pointer :: iodesc integer :: grid_id ! grid ID for data mapping - integer :: j ! indice + integer :: j ! index integer :: ierr ! error status type(var_desc_t) :: varid ! variable id integer :: no_fill @@ -494,7 +494,7 @@ subroutine infld_real_2d_3d(varname, ncid, dimname1, dimname2, & ! !LOCAL VARIABLES: type(io_desc_t), pointer :: iodesc integer :: grid_id ! grid ID for data mapping - integer :: j ! indice + integer :: j ! index integer :: ierr ! error status type(var_desc_t) :: varid ! variable id diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index aaf7fc2d86..302b8b44bb 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -287,7 +287,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) scm_clubb_iop_name = ' ' scm_relax_fincl(:) = ' ' if( single_column ) then - if( npes.gt.1) call endrun('SCAM_READNL: SCAM doesnt support using more than 1 pe.') + if( npes>1) call endrun('SCAM_READNL: SCAM doesnt support using more than 1 pe.') if ( .not. (dycore_is('EUL') .or. dycore_is('SE')) .or. plon /= 1 .or. plat /=1 ) then call endrun('SCAM_SETOPTS: must compile model for SCAM mode when namelist parameter single_column is .true.') @@ -296,9 +296,9 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) scmlat=scmlat_in scmlon=scmlon_in - if( scmlat .lt. -90._r8 .or. scmlat .gt. 90._r8 ) then + if( scmlat < -90._r8 .or. scmlat > 90._r8 ) then call endrun('SCAM_READNL: SCMLAT must be between -90. and 90. degrees.') - elseif( scmlon .lt. 0._r8 .or. scmlon .gt. 360._r8 ) then + elseif( scmlon < 0._r8 .or. scmlon > 360._r8 ) then call endrun('SCAM_READNL: SCMLON must be between 0. and 360. degrees.') end if @@ -320,7 +320,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) ! Error checking: iopfile = trim(iopfile) - if( iopfile .ne. "" ) then + if( iopfile /= "" ) then use_iop = .true. else call endrun('SCAM_READNL: must specify IOP file for single column mode') @@ -328,7 +328,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) call wrap_open( iopfile, NF90_NOWRITE, ncid ) - if( nf90_inquire_attribute( ncid, NF90_GLOBAL, 'CAM_GENERATED_FORCING', iatt ) .EQ. NF90_NOERR ) then + if( nf90_inquire_attribute( ncid, NF90_GLOBAL, 'CAM_GENERATED_FORCING', iatt ) == NF90_NOERR ) then use_camiop = .true. else use_camiop = .false. @@ -371,7 +371,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) write (iulog,*) ' scm_relax_finc: ' ! output scm_relax_fincl character array do i=1,pcnst - if (scm_relax_fincl(i) .ne. '') then + if (scm_relax_fincl(i) /= '') then adv = mod(i,4)==0 if (adv) then write (iulog, "(A18)") "'"//trim(scm_relax_fincl(i))//"'," @@ -398,8 +398,6 @@ subroutine readiopdata(hvcoord) ! Written by J. Truesdale August, 1996, revised January, 1998 ! !----------------------------------------------------------------------- -!jt fix this circular depend use phys_grid, only: clat_p -!jt use commap, only: latdeg, clat use hybvcoord_mod, only: hvcoord_t use getinterpnetcdfdata, only: getinterpncdata use shr_sys_mod, only: shr_sys_flush @@ -490,7 +488,7 @@ subroutine readiopdata(hvcoord) ! read level data ! status = NF90_INQ_DIMID( ncid, 'lev', lev_dimID ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable dim ID for lev' status = NF90_CLOSE ( ncid ) return @@ -502,7 +500,7 @@ subroutine readiopdata(hvcoord) allocate(dplevs(nlev+1)) status = NF90_INQ_VARID( ncid, 'lev', lev_varID ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for lev' status = NF90_CLOSE ( ncid ) return @@ -529,7 +527,7 @@ subroutine readiopdata(hvcoord) endif status = nf90_inq_varid( ncid, 'Ps', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_ps = .false. if (masterproc) write(iulog,*) sub//':Could not find variable Ps' if ( .not. scm_backfill_iop_w_init ) then @@ -588,7 +586,7 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,co2vmrobs) else - write(6,*)'using column value of co2vmr from boundary data as global volume mixing ratio' + if (is_first_step()) write(iulog,*)'using column value of co2vmr from boundary data as global volume mixing ratio' end if status = nf90_inq_varid( ncid, 'ch4vmr', varid ) if ( status == nf90_noerr) then @@ -596,7 +594,7 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,ch4vmrobs) else - write(6,*)'using column value of ch4vmr from boundary data as global volume mixing ratio' + if (is_first_step()) write(iulog,*)'using column value of ch4vmr from boundary data as global volume mixing ratio' end if status = nf90_inq_varid( ncid, 'n2ovmr', varid ) if ( status == nf90_noerr) then @@ -604,7 +602,7 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,n2ovmrobs) else - write(6,*)'using column value of n2ovmr from boundary data as global volume mixing ratio' + if (is_first_step()) write(iulog,*)'using column value of n2ovmr from boundary data as global volume mixing ratio' end if status = nf90_inq_varid( ncid, 'f11vmr', varid ) if ( status == nf90_noerr) then @@ -612,7 +610,7 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,f11vmrobs) else - write(6,*)'using column value of f11vmr from boundary data as global volume mixing ratio' + if (is_first_step()) write(iulog,*)'using column value of f11vmr from boundary data as global volume mixing ratio' end if status = nf90_inq_varid( ncid, 'f12vmr', varid ) if ( status == nf90_noerr) then @@ -620,7 +618,7 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,f12vmrobs) else - write(6,*)'using column value of f12vmr from boundary data as global volume mixing ratio' + if (is_first_step()) write(iulog,*)'using column value of f12vmr from boundary data as global volume mixing ratio' end if status = nf90_inq_varid( ncid, 'soltsi', varid ) if ( status == nf90_noerr) then @@ -628,13 +626,13 @@ subroutine readiopdata(hvcoord) call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) call wrap_get_vara_realx (ncid,varid,strt4,cnt4,soltsiobs) else - write(6,*)'using column value of soltsi from boundary data as global solar tsi' + if (is_first_step()) write(iulog,*)'using column value of soltsi from boundary data as global solar tsi' end if !===================================================================== !get global vmrs from camiop file status = nf90_inq_varid( ncid, 'Tsair', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_tsair = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -656,7 +654,7 @@ subroutine readiopdata(hvcoord) tsair(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tobs, status ) endif - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_t = .false. if (masterproc) write(iulog,*) sub//':Could not find variable T' if ( .not. scm_backfill_iop_w_init ) then @@ -673,7 +671,7 @@ subroutine readiopdata(hvcoord) endif status = nf90_inq_varid( ncid, 'Tg', varid ) - if (status .ne. nf90_noerr) then + if (status /= nf90_noerr) then if (masterproc) write(iulog,*) sub//':Could not find variable Tg on IOP dataset' if ( have_tsair ) then if (masterproc) write(iulog,*) sub//':Using Tsair' @@ -692,7 +690,7 @@ subroutine readiopdata(hvcoord) status = nf90_inq_varid( ncid, 'qsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -704,7 +702,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, qobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_q = .false. if (masterproc) write(iulog,*) sub//':Could not find variable q' if ( .not. scm_backfill_iop_w_init ) then @@ -720,7 +718,7 @@ subroutine readiopdata(hvcoord) cldobs = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'cld', .false., & dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_cld = .false. else have_cld = .true. @@ -729,7 +727,7 @@ subroutine readiopdata(hvcoord) clwpobs = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'clwp', .false., & dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, clwpobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_clwp = .false. else have_clwp = .true. @@ -739,7 +737,7 @@ subroutine readiopdata(hvcoord) ! read divq (horizontal advection) ! status = nf90_inq_varid( ncid, 'divqsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -752,7 +750,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'divq', have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq(:,1), status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divq = .false. else have_divq = .true. @@ -762,7 +760,7 @@ subroutine readiopdata(hvcoord) ! read vertdivq if available ! status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -775,14 +773,14 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivq', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivq(:,1), status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_vertdivq = .false. else have_vertdivq = .true. endif status = nf90_inq_varid( ncid, 'vertdivqsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -798,7 +796,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dten', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq3d(:,m), status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_cnst(m) = .false. divq3d(1:,m)=0._r8 else @@ -810,7 +808,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dqfx', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, coldata, status ) - if ( STATUS .NE. NF90_NOERR ) then + if ( STATUS /= NF90_NOERR ) then dqfxcam(1,:,m)=0._r8 else dqfxcam(1,:,m)=coldata(:) @@ -820,7 +818,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_alph', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tmpdata, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then alphacam(m)=0._r8 else alphacam(m)=tmpdata(1) @@ -836,7 +834,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMLIQ', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numliqobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_numliq = .false. else have_numliq = .true. @@ -853,7 +851,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDLIQ', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldliqobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_cldliq = .false. else have_cldliq = .true. @@ -868,7 +866,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDICE', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldiceobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_cldice = .false. else have_cldice = .true. @@ -884,7 +882,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMICE', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numiceobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_numice = .false. else have_numice = .true. @@ -897,7 +895,7 @@ subroutine readiopdata(hvcoord) ! read divu (optional field) ! status = nf90_inq_varid( ncid, 'divusrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -909,7 +907,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divu', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divu = .false. else have_divu = .true. @@ -918,7 +916,7 @@ subroutine readiopdata(hvcoord) ! read divv (optional field) ! status = nf90_inq_varid( ncid, 'divvsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -930,7 +928,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divv', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divv = .false. else have_divv = .true. @@ -939,7 +937,7 @@ subroutine readiopdata(hvcoord) ! read divt (optional field) ! status = nf90_inq_varid( ncid, 'divtsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -951,7 +949,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'divT', have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divt = .false. else have_divt = .true. @@ -961,7 +959,7 @@ subroutine readiopdata(hvcoord) ! read vertdivt if available ! status = nf90_inq_varid( ncid, 'vertdivTsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -973,11 +971,11 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivTx', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_vertdivt = .false. else have_vertdivt = .true. @@ -990,7 +988,7 @@ subroutine readiopdata(hvcoord) ! (optional field) status = nf90_inq_varid( ncid, 'divT3dsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1003,7 +1001,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divT3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt3d, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divt3d = .false. else have_divt3d = .true. @@ -1014,7 +1012,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divU3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu3d, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divu3d = .false. else have_divu3d = .true. @@ -1025,14 +1023,14 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divV3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv3d, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_divv3d = .false. else have_divv3d = .true. endif status = nf90_inq_varid( ncid, 'Ptend', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_ptend = .false. if (masterproc) write(iulog,*) sub//':Could not find variable Ptend. Setting to zero' ptend = 0.0_r8 @@ -1048,7 +1046,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'omega', .true., ptend, fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, wfld, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_omega = .false. if (masterproc) write(iulog,*) sub//':Could not find variable omega' if ( .not. scm_backfill_iop_w_init ) then @@ -1074,7 +1072,7 @@ subroutine readiopdata(hvcoord) end do status = nf90_inq_varid( ncid, 'usrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1087,14 +1085,14 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'u', have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, uobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_u = .false. else have_u = .true. endif status = nf90_inq_varid( ncid, 'vsrf', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_srf = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1107,7 +1105,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'v', have_srf, srf(1), fill_ends, scm_crm_mode, & dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vobs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_v = .false. else have_v = .true. @@ -1115,7 +1113,7 @@ subroutine readiopdata(hvcoord) call shr_sys_flush( iulog ) status = nf90_inq_varid( ncid, 'Prec', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_prec = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1128,7 +1126,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q1', & .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q1 at surface dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_q1 = .false. else have_q1 = .true. @@ -1139,7 +1137,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q2', & .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q2 at surface dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_q2 = .false. else have_q2 = .true. @@ -1149,9 +1147,9 @@ subroutine readiopdata(hvcoord) ! Analagous changes made for the surface heat flux status = nf90_inq_varid( ncid, 'lhflx', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then status = nf90_inq_varid( ncid, 'lh', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_lhflx = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1165,9 +1163,9 @@ subroutine readiopdata(hvcoord) endif status = nf90_inq_varid( ncid, 'shflx', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then status = nf90_inq_varid( ncid, 'sh', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then have_shflx = .false. else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1184,7 +1182,7 @@ subroutine readiopdata(hvcoord) ! If REPLAY is used, then need to read in the global ! energy fixer status = nf90_inq_varid( ncid, 'heat_glob', varid ) - if (status .ne. nf90_noerr) then + if (status /= nf90_noerr) then have_heat_glob = .false. else call wrap_get_vara_realx (ncid,varid,strt4,cnt4,heat_glob_scm) @@ -1223,15 +1221,8 @@ subroutine readiopdata(hvcoord) call shr_sys_flush( iulog ) -!!$ status = nf90_inq_varid( ncid, 'CLAT', varid ) -!!$ if ( status == nf90_noerr ) then -!!$ call wrap_get_vara_realx (ncid,varid,strt4,cnt4,clat) -!!$!jt fix this circ depend clat_p(1)=clat(1) -!!$ latdeg(1) = clat(1)*45._r8/atan(1._r8) -!!$ endif - status = nf90_inq_varid( ncid, 'beta', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then betacam = 0._r8 else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1240,7 +1231,7 @@ subroutine readiopdata(hvcoord) endif status = nf90_inq_varid( ncid, 'fixmas', varid ) - if ( status .ne. nf90_noerr ) then + if ( status /= nf90_noerr ) then fixmascam=1.0_r8 else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -1463,13 +1454,13 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , ! ! surface variables ! - if ( var_ndims .EQ. 0 ) then + if ( var_ndims == 0 ) then call endrun('SCAMMOD: var_ndims is 0 for varid:',varid) return endif STATUS = NF90_INQUIRE_VARIABLE( NCID, varID, dimids=var_dimIDs) - if ( STATUS .NE. NF90_NOERR ) then + if ( STATUS /= NF90_NOERR ) then write(iulog,* ) 'ERROR - extractdata.F:Cant get dimension IDs for varid', varid return endif @@ -1483,21 +1474,21 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , usable_var = .false. STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), dim_name ) - if ( trim(dim_name) .EQ. 'lat' ) then + if ( trim(dim_name) == 'lat' ) then start( i ) = latIdx count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 usable_var = .true. endif - if ( trim(dim_name) .EQ. 'lon' .or. trim(dim_name) .EQ. 'ncol' .or. trim(dim_name) .EQ. 'ncol_d' ) then + if ( trim(dim_name) == 'lon' .or. trim(dim_name) == 'ncol' .or. trim(dim_name) == 'ncol_d' ) then start( i ) = lonIdx count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 usable_var = .true. endif - if ( trim(dim_name) .EQ. 'lev' ) then + if ( trim(dim_name) == 'lev' ) then STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), len=nlev ) start( i ) = 1 count( i ) = nlev ! Extract all levels @@ -1505,7 +1496,7 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , usable_var = .true. endif - if ( trim(dim_name) .EQ. 'ilev' ) then + if ( trim(dim_name) == 'ilev' ) then STATUS = NF90_INQUIRE_DIMENSION( NCID, var_dimIDs( i ), len=nlev ) start( i ) = 1 count( i ) = nlev ! Extract all levels @@ -1513,7 +1504,7 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , usable_var = .true. endif - if ( trim(dim_name) .EQ. 'time' .OR. trim(dim_name) .EQ. 'tsec' ) then + if ( trim(dim_name) == 'time' .OR. trim(dim_name) == 'tsec' ) then start( i ) = TimeIdx count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 @@ -1561,42 +1552,42 @@ subroutine setiopupdate_init ! Read time (tsec) variable STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) - if ( STATUS .NE. NF90_NOERR ) write(iulog,*)'ERROR - setiopupdate.F:', & + if ( STATUS /= NF90_NOERR ) write(iulog,*)'ERROR - setiopupdate.F:', & 'Cant get variable ID for tsec' STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR ) then + if ( STATUS /= NF90_NOERR ) then STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) - if ( STATUS .NE. NF90_NOERR ) & + if ( STATUS /= NF90_NOERR ) & write(iulog,*)'ERROR - setiopupdate.F:Cant get variable ID for bdate' endif STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then + if ( STATUS /= NF90_NOERR ) then STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) - if ( STATUS .NE. NF90_NOERR ) then + if ( STATUS /= NF90_NOERR ) then write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' STATUS = NF90_CLOSE ( NCID ) return end if end if - if ( STATUS .NE. NF90_NOERR ) & + if ( STATUS /= NF90_NOERR ) & write(iulog,*)'ERROR - setiopupdate.F:Cant get variable dim ID for time' STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) - if ( STATUS .NE. NF90_NOERR )then + if ( STATUS /= NF90_NOERR )then write(iulog,*)'ERROR - setiopupdate.F:Cant get time dimlen' endif if (.not.allocated(tsec)) allocate(tsec(ntime)) STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) - if ( STATUS .NE. NF90_NOERR )then + if ( STATUS /= NF90_NOERR )then write(iulog,*)'ERROR - setiopupdate.F:Cant get variable tsec' endif STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) - if ( STATUS .NE. NF90_NOERR )then + if ( STATUS /= NF90_NOERR )then write(iulog,*)'ERROR - setiopupdate.F:Cant get variable bdate' endif @@ -1614,8 +1605,8 @@ subroutine setiopupdate_init call get_start_date(yr,mon,day,start_tod) start_ymd = yr*10000 + mon*100 + day - if ( start_ymd .gt. next_date .or. (start_ymd .eq. next_date & - .and. start_tod .ge. next_sec)) then + if ( start_ymd > next_date .or. (start_ymd == next_date & + .and. start_tod >= next_sec)) then iopTimeIdx = i endif enddo @@ -1623,7 +1614,7 @@ subroutine setiopupdate_init call get_curr_date(yr,mon,day,ncsec) ncdate=yr*10000 + mon*100 + day - if (iopTimeIdx == 0.or.iopTimeIdx .ge. ntime) then + if (iopTimeIdx == 0.or.iopTimeIdx >= ntime) then call timemgr_time_inc(bdate, 0, next_date, next_sec, inc_s=tsec(1)) write(iulog,*) 'Error::setiopupdate: Current model time does not fall within IOP period' write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' diff --git a/src/dynamics/eul/dyn_comp.F90 b/src/dynamics/eul/dyn_comp.F90 index 6b0a6f1af6..a6dcec74f8 100644 --- a/src/dynamics/eul/dyn_comp.F90 +++ b/src/dynamics/eul/dyn_comp.F90 @@ -11,7 +11,7 @@ module dyn_comp use physconst, only: pi use pmgrid, only: plon, plat, plev, plevp, plnlv, beglat, endlat -use commap, only: clat, clon +use commap, only: clat, clon, latdeg use dyn_grid, only: ptimelevels @@ -531,8 +531,9 @@ subroutine read_inidat() if (.not. readvar) then call endrun('CLAT not on iop initial file') else - clat(:) = clat2d(1,:) - clat_p(:)=clat(:) + clat = clat2d(1,1) + clat_p(:)=clat2d(1,1) + latdeg(1) = clat(1)*45._r8/atan(1._r8) end if fieldname = 'CLON1' diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index 853ccb4ddd..5916b02572 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -1,7 +1,7 @@ module apply_iop_forcing_mod use shr_kind_mod, only:r8 => shr_kind_r8, i8 => shr_kind_i8 -use pmgrid +use pmgrid, only:plev, plevp use constituents, only:pcnst, cnst_get_ind use physconst, only:rair,cpair use cam_logfile, only:iulog From 6e9b777dac26f61b5c27a673696bcfdfba62bffc Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Mon, 26 Feb 2024 08:17:32 -0700 Subject: [PATCH 13/75] check for error with mpi_bcast calls --- src/dynamics/se/se_single_column_mod.F90 | 43 ++++++++++++++++++++---- 1 file changed, 37 insertions(+), 6 deletions(-) diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 88b97e68c2..98717d39b2 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -247,44 +247,75 @@ subroutine iop_broadcast() ! flags and data to all processors !---------------------------------------------------------- - use spmd_utils, only: mpi_logical, mpi_real8, masterproc, iam, mpicom, mstrid=>masterprocid + use spmd_utils, only: mpi_logical, mpi_real8, masterproc, iam, mpicom, mstrid=>masterprocid + use cam_abortutils, only: endrun integer :: ierr -#ifdef SPMD + character(len=*), parameter :: sub = 'radiation_readnl' +#ifdef SPMD call mpi_bcast(have_ps,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_ps") call mpi_bcast(have_tg,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_tg") call mpi_bcast(have_lhflx,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_lhflx") call mpi_bcast(have_shflx,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_shflx") call mpi_bcast(have_t,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_t") call mpi_bcast(have_q,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_q") call mpi_bcast(have_u,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_u") call mpi_bcast(have_v,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_v") call mpi_bcast(have_omega,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_omega") call mpi_bcast(have_cldliq,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_cldliq") call mpi_bcast(have_divt,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_divt") call mpi_bcast(have_divq,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_divq") call mpi_bcast(have_divt3d,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_divt3d") call mpi_bcast(have_divq3d,1,mpi_logical,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_divq3d") call mpi_bcast(use_3dfrc,1,mpi_logical,mstrid,mpicom,ierr) - + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_3dfrc") + call mpi_bcast(psobs,1,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: psobs") call mpi_bcast(tground,1,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: tground") call mpi_bcast(lhflxobs,1,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: lhflxobs") call mpi_bcast(shflxobs,1,mpi_real8,mstrid,mpicom,ierr) - + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: shflxobs") + call mpi_bcast(tobs,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: tobs") call mpi_bcast(qobs,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: qobs") call mpi_bcast(uobs,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: uobs") call mpi_bcast(vobs,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: vobs") call mpi_bcast(cldliqobs,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: cldliqobs") call mpi_bcast(wfld,nlev,mpi_real8,mstrid,mpicom,ierr) - + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: wfld") + call mpi_bcast(divt,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divt") call mpi_bcast(divq,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divq") call mpi_bcast(divt3d,nlev,mpi_real8,mstrid,mpicom,ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divt3d") call mpi_bcast(divq3d,nlev,mpi_real8,mstrid,mpicom,ierr) - + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divq3d") + #endif end subroutine iop_broadcast From 91af07de2460f612faa465feaafc0415161b6f35 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 5 Mar 2024 13:17:33 -0700 Subject: [PATCH 14/75] PR requested updates --- src/control/history_scam.F90 | 59 +++++++++++------------- src/dynamics/eul/scmforecast.F90 | 15 ++++-- src/dynamics/se/se_single_column_mod.F90 | 43 ++++++++--------- src/physics/cam/check_energy.F90 | 18 +++----- 4 files changed, 65 insertions(+), 70 deletions(-) diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index e2acaef74e..d7710631a6 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -72,8 +72,8 @@ subroutine scm_intht() call addfld ('DIVU', (/ 'lev' /), 'A', 'm/s2','U advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVT', (/ 'lev' /), 'A', 'K/s','T advection tendency (horizontal)', gridname='physgrid') call addfld ('DIVT3D', (/ 'lev' /), 'A', 'K/s','T advection tendency (horiz/vert combined)', gridname=trim(outgrid)) - call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname=trim(outgrid)) - call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname=trim(outgrid)) + call addfld ('DIVU3D', (/ 'lev' /), 'A', 'K/s','U advection tendency (horiz/vert combined)', gridname=trim(outgrid)) + call addfld ('DIVV3D', (/ 'lev' /), 'A', 'K/s','V advection tendency (horiz/vert combined)', gridname=trim(outgrid)) call addfld ('SHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface sensible heat flux', gridname='physgrid') call addfld ('LHFLXOBS', horiz_only, 'A', 'W/m2','Obs Surface latent heat flux', gridname='physgrid') @@ -85,35 +85,32 @@ subroutine scm_intht() ! Vertical advective forcing of 'T,u,v,qv,ql,qi,nl,ni' in forecast.F90 - call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname=trim(outgrid) ) - call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname=trim(outgrid) ) - -! call addfld ('T3D_ADV_SLT', 'K/s' , pver, 'I', 'T 3d slt advective forcing', gridname='physgrid') -! call addfld ('U3D_ADV_SLT', 'm/s^2' , pver, 'I', 'U 3d slt advective forcing', gridname='physgrid') -! call addfld ('V3D_ADV_SLT', 'm/s^2' , pver, 'I', 'V 3d slt advective forcing', gridname='physgrid') - call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname=trim(outgrid) ) - - call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname=trim(outgrid) ) - call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('TTEN_XYADV', (/ 'lev' /), 'I', 'K/s', 'T horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('UTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'U horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('VTEN_XYADV', (/ 'lev' /), 'I', 'm/s^2', 'V horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('QVTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QV horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('QLTEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QL horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('QITEN_XYADV', (/ 'lev' /), 'I', 'kg/kg/s','QI horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('NLTEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NL horizontal advective forcing', gridname=trim(outgrid) ) + call addfld ('NITEN_XYADV', (/ 'lev' /), 'I', '#/kg/s', 'NI horizontal advective forcing', gridname=trim(outgrid) ) + + call addfld ('TTEN_ZADV', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('UTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('VTEN_ZADV', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QVTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QV vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QLTEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QL vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QITEN_ZADV', (/ 'lev' /), 'I', 'kg/kg/s','QI vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('NLTEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NL vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('NITEN_ZADV', (/ 'lev' /), 'I', '#/kg/s', 'NI vertical advective forcing', gridname=trim(outgrid) ) + + call addfld ('TTEN_PHYS', (/ 'lev' /), 'I', 'K/s', 'T vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('UTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'U vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('VTEN_PHYS', (/ 'lev' /), 'I', 'm/s^2', 'V vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QVTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QV vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QLTEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QL vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('QITEN_PHYS', (/ 'lev' /), 'I','kg/kg/s','QI vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('NLTEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NL vertical advective forcing', gridname=trim(outgrid) ) + call addfld ('NITEN_PHYS', (/ 'lev' /), 'I','#/kg/s', 'NI vertical advective forcing', gridname=trim(outgrid) ) end subroutine scm_intht !####################################################################### diff --git a/src/dynamics/eul/scmforecast.F90 b/src/dynamics/eul/scmforecast.F90 index d893e46d92..decdff9c7f 100644 --- a/src/dynamics/eul/scmforecast.F90 +++ b/src/dynamics/eul/scmforecast.F90 @@ -100,13 +100,15 @@ subroutine forecast( lat , nlon , ztodt , & real(r8), intent(inout) :: uten_phys(plev) ! Tendency of u by the sum of 'physics + geostrophic forcing' [ m/s/s ] real(r8), intent(inout) :: vten_phys(plev) ! Tendency of v by the sum of 'physics + geostrophic forcing' [ m/s/s ] real(r8) qten_phys(plev,pcnst) ! Tendency of q by the 'physics' [ #/kg/s, kg/kg/s ] - real(r8), intent(in) :: qminus(plon,plev,pcnst) ! ( qminus - q3m2 ) / ztodt = Tendency of tracers by the 'physics' [ #/kg/s, kg/kg/s ] + real(r8), intent(in) :: qminus(plon,plev,pcnst) ! (qminus - q3m2) / ztodt = + ! Tendency of tracers by the 'physics' [ #/kg/s, kg/kg/s ] real(r8), intent(out) :: t3(plev) ! Temperature [ K ] real(r8), intent(out) :: u3(plev) ! Zonal wind [ m/s ] real(r8), intent(out) :: v3(plev) ! Meridional wind [ m/s ] real(r8), intent(inout) :: q3(plev,pcnst) ! Tracers [ #/kg, kg/kg ] - real(r8), intent(inout) :: qfcst(plon,plev,pcnst) ! ( Input qfcst - q3m2 ) / ztodt = Tendency of q by the sum of 'physics' + 'SLT vertical advection' [ #/kg/s, kg/kg/s ] + real(r8), intent(inout) :: qfcst(plon,plev,pcnst) ! ( Input qfcst - q3m2 ) / ztodt = Tendency of q by the sum of 'physics' + + ! 'SLT vertical advection' [ #/kg/s, kg/kg/s ] ! --------------- ! @@ -123,9 +125,12 @@ subroutine forecast( lat , nlon , ztodt , & real(r8) pdelm1(plev) real(r8) wfldint(plevp) real(r8) pdelb(plon,plev) - real(r8) tfcst(plev) ! ( tfcst - t3m2 ) / ztodt = Tendency of T by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ K/s ] - real(r8) ufcst(plev) ! ( ufcst - u3m2 ) / ztodt = Tendency of u by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ m/s/s ] - real(r8) vfcst(plev) ! ( vfcst - u3m2 ) / ztodt = Tendency of v by the sum of 'physics' + 'SLT/EUL/XXX vertical advection' [ m/s/s ] + real(r8) tfcst(plev) ! ( tfcst - t3m2 ) / ztodt = Tendency of T by the sum of 'physics' + + ! 'SLT/EUL/XXX vertical advection' [ K/s ] + real(r8) ufcst(plev) ! ( ufcst - u3m2 ) / ztodt = Tendency of u by the sum of 'physics' + + ! 'SLT/EUL/XXX vertical advection' [ m/s/s ] + real(r8) vfcst(plev) ! ( vfcst - u3m2 ) / ztodt = Tendency of v by the sum of 'physics' + + ! 'SLT/EUL/XXX vertical advection' [ m/s/s ] logical scm_fincl_empty ! ----------------------------------------------- ! ! Centered Eulerian vertical advective tendencies ! diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 98717d39b2..2beef53e8f 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -32,7 +32,7 @@ module se_single_column_mod integer, public :: indx_scm, ie_scm, i_scm, j_scm -integer :: tl_f, tl_fqdp, thelev +integer :: tl_f, tl_fqdp, thelev !========================================================================= contains @@ -47,9 +47,8 @@ subroutine scm_setinitial(elem) type(element_t), intent(inout) :: elem(:) - integer k - integer inumliq, inumice, icldliq, icldice - integer :: tl_f, tl_fqdp + integer :: levidx(1) + integer :: inumliq, inumice, icldliq, icldice, levidx(1) call scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) @@ -63,15 +62,8 @@ subroutine scm_setinitial(elem) call cnst_get_ind('CLDICE', icldice) ! Find level where tobs is no longer zero - thelev=1 - do k=1, NLEV - if (tobs(k) /= 0) then - thelev=k - go to 1000 - endif - enddo - -1000 continue + levidx=MINLOC(tobs, MASK = tobs == 0._r8) + thelev=levidx(1) if (get_nstep() <= 1) then do k=1,thelev-1 @@ -93,10 +85,14 @@ subroutine scm_setinitial(elem) if (have_ps) elem(ie_scm)%state%psdry(i_scm,j_scm) = psobs if (have_u) elem(ie_scm)%state%v(i_scm,j_scm,1,k,tl_f) = uobs(k) if (have_v) elem(ie_scm)%state%v(i_scm,j_scm,2,k,tl_f) = vobs(k) - if (have_numliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumliq,tl_fqdp) = numliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) - if (have_cldliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldliq,tl_fqdp) = cldliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) - if (have_numice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumice,tl_fqdp) = numiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) - if (have_cldice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldice,tl_fqdp) = cldiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_numliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumliq,tl_fqdp) = & + numliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_cldliq) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldliq,tl_fqdp) = & + cldliqobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_numice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,inumice,tl_fqdp) = & + numiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) + if (have_cldice) elem(ie_scm)%state%qdp(i_scm,j_scm,k,icldice,tl_fqdp) = & + cldiceobs(k)*elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) if (have_omega) elem(ie_scm)%derived%omega(i_scm,j_scm,k) = wfld(k) enddo @@ -174,7 +170,7 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance) ! Set initial profiles for current column do m=1,pcnst - stateQ_in(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) + stateQ_in(:nlev,m) = elem(ie_scm)%state%Qdp(i_scm,j_scm,:nlev,m,tl_fqdp)/elem(ie_scm)%state%dp3d(i_scm,j_scm,:nlev,tl_f) end do t_in(:nlev) = elem(ie_scm)%state%T(i_scm,j_scm,:nlev,tl_f) u_in(:nlev) = elem(ie_scm)%state%v(i_scm,j_scm,1,:nlev,tl_f) @@ -198,7 +194,8 @@ subroutine apply_SC_forcing(elem,hvcoord,tl,n,t_before_advance) if (use_3dfrc) then ! vertical remap of dynamics not run need to update state%dp3d using new psdry do k=1,nlev - elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) = (hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + (hvcoord%hybi(k+1)-hvcoord%hybi(k))*elem(ie_scm)%state%psdry(i_scm,j_scm) + elem(ie_scm)%state%dp3d(i_scm,j_scm,k,tl_f) = (hvcoord%hyai(k+1)-hvcoord%hyai(k))*hvcoord%ps0 + & + (hvcoord%hybi(k+1)-hvcoord%hybi(k))*elem(ie_scm)%state%psdry(i_scm,j_scm) end do end if @@ -284,7 +281,7 @@ subroutine iop_broadcast() if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: have_divq3d") call mpi_bcast(use_3dfrc,1,mpi_logical,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_3dfrc") - + call mpi_bcast(psobs,1,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: psobs") call mpi_bcast(tground,1,mpi_real8,mstrid,mpicom,ierr) @@ -293,7 +290,7 @@ subroutine iop_broadcast() if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: lhflxobs") call mpi_bcast(shflxobs,1,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: shflxobs") - + call mpi_bcast(tobs,nlev,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: tobs") call mpi_bcast(qobs,nlev,mpi_real8,mstrid,mpicom,ierr) @@ -306,7 +303,7 @@ subroutine iop_broadcast() if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: cldliqobs") call mpi_bcast(wfld,nlev,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: wfld") - + call mpi_bcast(divt,nlev,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divt") call mpi_bcast(divq,nlev,mpi_real8,mstrid,mpicom,ierr) @@ -315,7 +312,7 @@ subroutine iop_broadcast() if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divt3d") call mpi_bcast(divq3d,nlev,mpi_real8,mstrid,mpicom,ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: divq3d") - + #endif end subroutine iop_broadcast diff --git a/src/physics/cam/check_energy.F90 b/src/physics/cam/check_energy.F90 index cead8fcf24..2ddd8b3b83 100644 --- a/src/physics/cam/check_energy.F90 +++ b/src/physics/cam/check_energy.F90 @@ -602,19 +602,15 @@ subroutine check_energy_fix(state, ptend, nstep, eshflx) ! disable the energy fix for offline driver heat_glob = 0._r8 #endif - ! add global mean total energy difference as heating - if (single_column .and. use_camiop) then - heat_glob = heat_glob_scm(1) - endif - ! In single column model we do NOT want to take into - ! consideration the dynamics energy fixer. Since only - ! one column of dynamics is active, this data will - ! essentially be garbage. - if (single_column .and. .not. use_camiop) then - heat_glob = 0._r8 + ! Special handling of energy fix for SCAM - supplied via CAMIOP - zero's for normal IOPs + if (single_column) then + if ( use_camiop) then + heat_glob = heat_glob_scm(1) + else + heat_glob = 0._r8 + endif endif -! add (-) global mean total energy difference as heating ptend%s(:ncol,:pver) = heat_glob if (nstep > 0 .and. write_camiop) then From 53300deb7b68232bf2aa00451102db855f99e1bd Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 5 Mar 2024 13:20:46 -0700 Subject: [PATCH 15/75] compile catch/fix for se_single_column_mod --- src/dynamics/se/se_single_column_mod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 2beef53e8f..9d9090dea2 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -47,8 +47,8 @@ subroutine scm_setinitial(elem) type(element_t), intent(inout) :: elem(:) - integer :: levidx(1) - integer :: inumliq, inumice, icldliq, icldice, levidx(1) + integer :: k, levidx(1) + integer :: inumliq, inumice, icldliq, icldice call scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) From 36e8f4b9731352336a6f74a0ab397020f1087998 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 5 Mar 2024 16:05:02 -0700 Subject: [PATCH 16/75] shorten a few long lines >132 --- src/control/scamMod.F90 | 10 +++++----- src/dynamics/se/advect_tend.F90 | 2 +- src/dynamics/se/dycore/prim_driver_mod.F90 | 3 ++- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index eed8e8965e..73d44e5d58 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -215,8 +215,8 @@ module scamMod logical, public :: scm_relaxation = .false. ! Use relaxation logical, public :: scm_crm_mode = .false. ! Use column radiation mode logical, public :: scm_cambfb_mode = .false. ! Use extra CAM IOP fields to assure bit for bit match with CAM run -logical, public :: scm_use_obs_T = .false. ! Use the SCAM-IOP specified observed T at each time step instead of forecasting. -logical, public :: scm_force_latlon = .false. ! force scam to use the lat lon fields specified in the scam namelist not what is closest to iop avail lat lon +logical, public :: scm_use_obs_T = .false. ! Use the SCAM-IOP observed T at each timestep instead of forecasting. +logical, public :: scm_force_latlon = .false. ! force scam to use the lat lon fields specified in the namelist not closest real(r8), public :: scm_relaxation_low ! lowest level to apply relaxation real(r8), public :: scm_relaxation_high ! highest level to apply relaxation real(r8), public :: scm_relax_top_p = 1.e36_r8 ! upper bound for scm relaxation @@ -234,10 +234,10 @@ module scamMod ! note that scm_use_obs_uv is set to true to be consistent with CAM BFB testing ! -logical, public :: scm_use_obs_uv = .true. ! Use the SCAM-IOP specified observed u,v at each time step instead of forecasting. +logical, public :: scm_use_obs_uv = .true. ! Use the SCAM-IOP observed u,v at each time step instead of forecasting. -logical, public :: scm_use_obs_qv = .false. ! Use the SCAM-IOP specified observed qv at each time step instead of forecasting. -logical, public :: scm_use_3dfrc = .false. ! Use the CAM/SCAM-IOP 3d forcing if true, else use dycore vertical plus horizontal advective forcing +logical, public :: scm_use_obs_qv = .false. ! Use the SCAM-IOPobserved qv at each time step instead of forecasting. +logical, public :: scm_use_3dfrc = .false. ! Use CAMIOP 3d forcing if true, else use dycore vertical plus horizontal logical, public :: scm_iop_lhflxshflxTg = .false. !turn off LW rad logical, public :: scm_iop_Tg = .false. !turn off LW rad diff --git a/src/dynamics/se/advect_tend.F90 b/src/dynamics/se/advect_tend.F90 index 004759f7a1..31cba03435 100644 --- a/src/dynamics/se/advect_tend.F90 +++ b/src/dynamics/se/advect_tend.F90 @@ -199,7 +199,7 @@ subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) out_v(i+(j-1)*np,:) = elem(ie)%state%v(i,j,2,:,n0) out_ps(i+(j-1)*np) = elem(ie)%state%psdry(i,j) - ! to retain bfb for scam check, replace state q and t with roundoff version calculated using the ordering and tendencies of the + ! to retain bfb, replace state q and t with roundoff version calculated using the ordering and tendencies of the ! scam prognostic equation elem(ie)%state%T(i,j,:,n0) = iop_ttendxyz_init(i,j,:,ie) + dt*(elem(ie)%derived%FT(i,j,:) + t_adv(i+(j-1)*np,:)) out_t(i+(j-1)*np,:) = elem(ie)%state%T(i,j,:,n0) diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index 6750d5dee9..3f8d1749c9 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -850,7 +850,8 @@ subroutine set_prescribed_scm(elem, fvm, deriv, hvcoord, & do p=1,qsize do k=1,nlev elem(ie)%state%Qdp(:,:,k,p,qnp1) = elem(ie)%state%Qdp(:,:,k,p,qn0) & - + elem(ie)%state%Qdp(:,:,k,p,qn0)/elem(ie)%state%dp3d(:,:,k,n0)*dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) + + elem(ie)%state%Qdp(:,:,k,p,qn0)/elem(ie)%state%dp3d(:,:,k,n0) * & + dt*(eta_dot_dpdn(:,:,k+1) - eta_dot_dpdn(:,:,k)) enddo enddo enddo From 8851ffde26d8c8d58ace4f806c72cbdf403d2764 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 5 Mar 2024 18:31:07 -0700 Subject: [PATCH 17/75] bugfix for new minloc replacement for loop with exit --- src/dynamics/se/se_single_column_mod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index 9d9090dea2..b45166dd6d 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -62,7 +62,7 @@ subroutine scm_setinitial(elem) call cnst_get_ind('CLDICE', icldice) ! Find level where tobs is no longer zero - levidx=MINLOC(tobs, MASK = tobs == 0._r8) + levidx=MINLOC(tobs, MASK = tobs /= 0._r8) thelev=levidx(1) if (get_nstep() <= 1) then From 5f7a485ccea92eaf2f9791917e63d4bfd8833ecb Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 7 Mar 2024 16:25:57 -0700 Subject: [PATCH 18/75] update ice external tag --- Externals.cfg | 4 ++-- src/dynamics/se/se_single_column_mod.F90 | 5 ++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 0a81de5eec..3afa205c8f 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -13,9 +13,9 @@ local_path = components/cice5 required = True [cice6] -tag = cesm_cice6_4_1_10_scamdev +tag = cesm_cice6_5_0_7 protocol = git -repo_url = https://github.com/jtruesdal/CESM_CICE +repo_url = https://github.com/ESCOMP/CESM_CICE local_path = components/cice externals = Externals.cfg required = True diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index b45166dd6d..cd8e56f2d1 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -47,7 +47,7 @@ subroutine scm_setinitial(elem) type(element_t), intent(inout) :: elem(:) - integer :: k, levidx(1) + integer :: k integer :: inumliq, inumice, icldliq, icldice call scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) @@ -62,8 +62,7 @@ subroutine scm_setinitial(elem) call cnst_get_ind('CLDICE', icldice) ! Find level where tobs is no longer zero - levidx=MINLOC(tobs, MASK = tobs /= 0._r8) - thelev=levidx(1) + thelev=minloc(abs(tobs), 1, mask=abs(tobs) > 0) if (get_nstep() <= 1) then do k=1,thelev-1 From bcd2ea54ec4b145151bae7b1ea4c475d781fa072 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 12 Mar 2024 21:45:11 -0600 Subject: [PATCH 19/75] dont need these cdep mods --- Externals.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index 3afa205c8f..4451a56eb9 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -28,9 +28,9 @@ local_path = components/cmeps required = True [cdeps] -branch = cdeps1.0.24_scamdev +tag = cdeps1.0.24 protocol = git -repo_url = https://github.com/jtruesdal/CDEPS.git +repo_url = https://github.com/ESCOMP/CDEPS.git local_path = components/cdeps externals = Externals_CDEPS.cfg required = True From 2e344b3d2e4178e3ebe0db3d7cbb447341faaffd Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 19 Apr 2024 12:02:19 -0600 Subject: [PATCH 20/75] PR updates for Jesse --- bld/build-namelist | 2 +- bld/config_files/definition.xml | 2 +- bld/namelist_files/namelist_defaults_cam.xml | 27 +- bld/namelist_files/namelist_definition.xml | 2 +- cime_config/SystemTests/sct.py | 3 +- cime_config/config_component.xml | 1 - cime_config/config_compsets.xml | 2 +- cime_config/testdefs/testlist_cam.xml | 6 +- .../scam_mandatory/shell_commands | 2 +- src/control/cam_history.F90 | 2 - src/control/getinterpnetcdfdata.F90 | 57 ++-- src/control/history_scam.F90 | 9 +- src/control/scamMod.F90 | 258 ++++++++---------- src/dynamics/se/advect_tend.F90 | 46 +++- src/dynamics/se/apply_iop_forcing.F90 | 67 +++-- src/dynamics/se/dycore/prim_driver_mod.F90 | 6 +- src/dynamics/se/se_single_column_mod.F90 | 9 +- 17 files changed, 248 insertions(+), 253 deletions(-) diff --git a/bld/build-namelist b/bld/build-namelist index 0af859aff2..b5a23452a9 100755 --- a/bld/build-namelist +++ b/bld/build-namelist @@ -4017,7 +4017,7 @@ if ($cfg->get('scam')) { if ($chem =~ /_mam/) { add_default($nl, 'scm_relax_fincl'); } - if ($cfg->get('scam_iop')) { + if ($scam_iop) { add_default($nl, 'iopfile'); } if ($scam_iop eq 'SAS') { diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index 491bffe94c..9f7f4d6aed 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -147,7 +147,7 @@ Turn on CO2 cycle in biogeochemistry model: 0 => no, 1 => yes. Modifications that allow perturbation growth testing: 0=off, 1=on. -Configure CAM for single column mode and specify an IOP. +Configure CAM for single column mode and specify an IOP: 0=no, 1=yes. This option only supported for the Eulerian and SE dycores. diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 9dafe39695..d8fe71c93c 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2884,6 +2884,7 @@ .true. 0.0D0 .true. + 10800._r8 'T', 'bc_a1', 'bc_a4', 'dst_a1', 'dst_a2', 'dst_a3', 'ncl_a1', 'ncl_a2', 'ncl_a3', 'num_a1', 'num_a2', 'num_a3', 'num_a4', 'pom_a1', 'pom_a4', 'so4_a1', 'so4_a2', 'so4_a3', 'soa_a1', 'soa_a2' @@ -2905,56 +2906,64 @@ - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM95_4scam.nc 368.9e-6 - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM97_4scam.nc 368.9e-6 + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-02-01-00000.nc atm/cam/scam/iop/ATEX_48hr_4scam.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/BOMEX_5day_4scam.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S11_CTL_MixedLayerInit_reduced.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S12_CTL_MixedLayerInit_reduced.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/S6_CTL_reduced.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/DYCOMSrf01_4day_4scam.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/DYCOMSrf02_48hr_4scam.nc - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-08-01-00000.nc atm/cam/scam/iop/GATEIII_4scam_c170809.nc + atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.Gaus_64x128.nc atm/cam/scam/iop/micre2017_3mo.macquarie2017.iop.nc - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-10-01-00000.nc atm/cam/scam/iop/MPACE_4scam.nc @@ -2971,10 +2980,12 @@ 'TGCLDLWP','GCLDLWP' + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-07-01-00000.nc atm/cam/scam/iop/RICO_3day_4scam.nc + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/SAS_ideal_4scam.nc @@ -2982,24 +2993,24 @@ .false. .true. - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-04-01-00000.nc atm/cam/scam/iop/SPARTICUS_4scam.nc - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-12-01-00000.nc atm/cam/scam/iop/TOGAII_4scam.nc - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-01-01-00000.nc atm/cam/scam/iop/TWP06_4scam.nc 1 1 - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM97_4scam.nc diff --git a/bld/namelist_files/namelist_definition.xml b/bld/namelist_files/namelist_definition.xml index 704453c375..66d28e2bba 100644 --- a/bld/namelist_files/namelist_definition.xml +++ b/bld/namelist_files/namelist_definition.xml @@ -5863,7 +5863,7 @@ Default: FALSE Use the SCAM-IOP 3d forcing if true, use combination of dycore vertical advection and iop horiz advection if false -Default: +Default:False -scam rico -scam sparticus -scam togaII - -scam user -scam twp06 -scam camfrc diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 7cbf457b67..b0c0eba678 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -158,7 +158,7 @@ FSCAMCGILSS6 - 2000_CAM60%SCAMCgilss6_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV + 2000_CAM60%SCAMCGILSS6_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index a54f48dbd4..b2644a677f 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1156,6 +1156,7 @@ + @@ -1349,7 +1350,8 @@ - + + @@ -1468,6 +1470,7 @@ + @@ -1477,6 +1480,7 @@ + diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index 0af79f293f..cfc2114554 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -9,7 +9,7 @@ ./xmlchange REST_OPTION=never # Note that clm cannot use initial conditions with SCAM -so will only use specified phenology -# Only change if CLM_FORCE_COLDSTART exists and dycore is eularian +# Only change if CLM_FORCE_COLDSTART exists and dycore is eulerian if [ `./xmlquery --value CAM_DYCORE` == 'eul' ] && [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then ./xmlchange CLM_FORCE_COLDSTART='on' fi diff --git a/src/control/cam_history.F90 b/src/control/cam_history.F90 index f70d32e7f5..1f7f8718d7 100644 --- a/src/control/cam_history.F90 +++ b/src/control/cam_history.F90 @@ -919,8 +919,6 @@ subroutine history_readnl(nlfile) end if if (inithist == 'CAMIOP') then write_camiop=.true. - else - write_camiop=.false. end if ! separate namelist reader for the satellite history file call sat_hist_readnl(nlfile, hfilename_spec, mfilt, fincl, nhtfrq, avgflag_pertape) diff --git a/src/control/getinterpnetcdfdata.F90 b/src/control/getinterpnetcdfdata.F90 index 15fa0e6798..536d72d5de 100644 --- a/src/control/getinterpnetcdfdata.F90 +++ b/src/control/getinterpnetcdfdata.F90 @@ -3,8 +3,8 @@ module getinterpnetcdfdata ! Description: ! Routines for extracting a column from a netcdf file ! -! Author: -! +! Author: +! ! Modules Used: ! use cam_abortutils, only: endrun @@ -24,7 +24,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & varName, have_surfdat, surfdat, fill_ends, scm_crm_mode, & press, npress, ps, hyam, hybm, outData, STATUS ) -! getinterpncdata: extracts the entire level dimension for a +! getinterpncdata: extracts the entire level dimension for a ! particular lat,lon,time from a netCDF file ! and interpolates it onto the input pressure levels, placing ! result in outData, and the error status inx STATUS @@ -40,13 +40,13 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & integer, intent(in) :: NCID ! NetCDF ID integer, intent(in) :: TimeIdx ! time index - real(r8), intent(in) :: camlat,camlon ! target lat and lon to be extracted + real(r8), intent(in) :: camlat,camlon ! target lat and lon to be extracted logical, intent(in) :: have_surfdat ! is surfdat provided logical, intent(in) :: fill_ends ! extrapolate the end values - logical, intent(in) :: scm_crm_mode ! extrapolate the end values + logical, intent(in) :: scm_crm_mode ! scam column radiation mode integer, intent(in) :: npress ! number of dataset pressure levels real(r8), intent(in) :: press(npress) ! dataset pressure levels - real(r8), intent(in) :: ps ! dataset pressure levels + real(r8), intent(in) :: ps ! surface pressure real(r8), intent(in) :: hyam(:) ! dataset hybrid midpoint pressure levels real(r8), intent(in) :: hybm(:) ! dataset hybrid midpoint pressure levels @@ -69,7 +69,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & integer dims_set integer i integer var_dimIDs( NF90_MAX_VAR_DIMS ) - integer start( NF90_MAX_VAR_DIMS ) + integer start( NF90_MAX_VAR_DIMS ) integer count( NF90_MAX_VAR_DIMS ) character varName*(*) @@ -117,9 +117,9 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & write(iulog,* ) 'ERROR - extractdata.F:Cant get dimension IDs for', varName return endif -! -! Initialize the start and count arrays -! +! +! Initialize the start and count arrays +! dims_set = 0 nlev = 1 do i = var_ndims, 1, -1 @@ -129,7 +129,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & if ( dim_name .EQ. 'lat' ) then start( i ) = latIdx - count( i ) = 1 ! Extract a single value + count( i ) = 1 ! Extract a single value dims_set = dims_set + 1 usable_var = .true. endif @@ -157,10 +157,10 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & usable_var = .true. endif - if ( dim_name .EQ. 'time' .OR. dim_name .EQ. 'tsec' ) then + if ( dim_name .EQ. 'time' .OR. dim_name .EQ. 'tsec' ) then start( i ) = TimeIdx - count( i ) = 1 ! Extract a single value - dims_set = dims_set + 1 + count( i ) = 1 ! Extract a single value + dims_set = dims_set + 1 usable_var = .true. endif @@ -189,11 +189,11 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & if ( nlev .eq. 1 ) then outdata(1) = tmp(1) - return ! no need to do interpolation + return ! no need to do interpolation endif ! if ( use_camiop .and. nlev.eq.plev) then if ( nlev.eq.plev .or. nlev.eq.plev+1) then - outData(:nlev)= tmp(:nlev)! no need to do interpolation + outData(:nlev)= tmp(:nlev)! no need to do interpolation else ! ! add the surface data if available, else @@ -226,7 +226,7 @@ subroutine getinterpncdata( NCID, camlat, camlon, TimeIdx, & endif ! ! reset status to zero -! +! STATUS = 0 ! do i=1, npress @@ -266,10 +266,10 @@ subroutine interplevs( inputdata, dplevs, nlev, & integer, intent(in) :: nlev ! num press levels in dataset real(r8), intent(in) :: ps ! surface pressure - real(r8), intent(in) :: hyam(:) ! a midpoint pressure - real(r8), intent(in) :: hybm(:) ! b midpoint pressure + real(r8), intent(in) :: hyam(:) ! a midpoint pressure + real(r8), intent(in) :: hybm(:) ! b midpoint pressure real(r8), intent(in) :: inputdata(nlev) ! data from netcdf dataset - real(r8), intent(in) :: dplevs(nlev) ! input data pressure levels + real(r8), intent(in) :: dplevs(nlev) ! input data pressure levels logical, intent(in) :: fill_ends ! fill in missing end values(used for ! global model datasets) @@ -284,7 +284,7 @@ subroutine interplevs( inputdata, dplevs, nlev, & real(r8) interpdata( PLEV ) - integer dstart_lev, dend_lev + integer dstart_lev, dend_lev integer mstart_lev, mend_lev integer data_nlevs, model_nlevs, i integer STATUS @@ -296,14 +296,14 @@ subroutine interplevs( inputdata, dplevs, nlev, & do i = 1, plev mplevs( i ) = 1000.0_r8 * hyam( i ) + ps * hybm( i ) / 100.0_r8 end do -! +! ! the following algorithm assumes that pressures are increasing in the ! arrays -! -! +! +! ! Find the data pressure levels that are just outside the range ! of the model pressure levels, and that contain valid values -! +! dstart_lev = 1 do i= 1, nlev if ( dplevs(i) .LE. mplevs(1) ) dstart_lev = i @@ -315,7 +315,7 @@ subroutine interplevs( inputdata, dplevs, nlev, & dend_lev = i endif end do -! +! ! Find the model pressure levels that are just inside the range ! of the data pressure levels ! @@ -343,10 +343,10 @@ subroutine interplevs( inputdata, dplevs, nlev, & outdata( i+mstart_lev-1 ) = interpdata( i ) end do ! -! fill in the missing end values +! fill in the missing end values ! (usually done if this is global model dataset) ! - if ( fill_ends ) then + if ( fill_ends ) then do i=1, mstart_lev outdata(i) = inputdata(1) end do @@ -358,4 +358,3 @@ subroutine interplevs( inputdata, dplevs, nlev, & return end subroutine interplevs end module getinterpnetcdfdata - diff --git a/src/control/history_scam.F90 b/src/control/history_scam.F90 index d7710631a6..e171fcee96 100644 --- a/src/control/history_scam.F90 +++ b/src/control/history_scam.F90 @@ -10,6 +10,7 @@ module history_scam !----------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 use cam_history, only: addfld, add_default, horiz_only + use cam_grid_support, only: max_hcoordname_len implicit none @@ -39,7 +40,7 @@ subroutine scm_intht() !----------------------------------------------------------------------- ! Local variables ! - character(len=100) outgrid + character(len=max_hcoordname_len) outgrid if (dycore_is('SE')) then ! for camiop mode use the GLL grid otherwise use physics grids for SCM mode output @@ -132,7 +133,7 @@ subroutine initialize_iop_history() ! !LOCAL VARIABLES: integer m - character(len=100) outgrid + character(len=max_hcoordname_len) outgrid !----------------------------------------------------------------------- @@ -159,7 +160,7 @@ subroutine initialize_iop_history() call addfld ('fixmas', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(outgrid)) call add_default ('fixmas',2,' ') - call addfld ('beta', horiz_only, 'A', 'percent','Mass fixer',gridname=trim(outgrid)) + call addfld ('beta', horiz_only, 'A', 'percent','Energy fixer',gridname=trim(outgrid)) call add_default ('beta',2,' ') end if @@ -173,7 +174,7 @@ subroutine initialize_iop_history() call add_default ('t',2,' ') call addfld ('Tg', horiz_only, 'A', 'K', 'Surface temperature (radiative) for scam',gridname='physgrid') call add_default ('Tg',2,' ') - call addfld ('Ps', horiz_only, 'A', 'Pa', 'Ps for scam',gridname=trim(outgrid)) + call addfld ('Ps', horiz_only, 'A', 'Pa', 'Surface Pressure for SCAM',gridname=trim(outgrid)) call add_default ('Ps',2,' ') call addfld ('divT3d', (/ 'lev' /), 'A', 'K', 'Dynamics Residual for T',gridname=trim(outgrid)) call add_default ('divT3d',2,' ') diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index 73d44e5d58..cfbcf8d78c 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -31,6 +31,7 @@ module scamMod use cam_logfile, only: iulog use cam_abortutils, only: endrun use time_manager, only: get_curr_date, get_nstep,is_first_step,get_start_date,timemgr_time_inc +use error_messages, only: handle_ncerr implicit none @@ -41,7 +42,7 @@ module scamMod public :: scam_readnl ! read SCAM namelist options public :: readiopdata ! read iop boundary data public :: setiopupdate ! find index in iopboundary data for current time -public :: plevs0 ! find index in iopboundary data for current time +public :: plevs0 ! Define the pressures of the interfaces and midpoints public :: scmiop_flbc_inti public :: setiopupdate_init @@ -73,24 +74,24 @@ module scamMod integer, public :: error_code ! Error code from netCDF reads integer, public :: initTimeIdx integer, public :: seedval -integer bdate, last_date, last_sec - -character*(max_path_len), public :: modelfile -character*(max_path_len), public :: analysisfile -character*(max_path_len), public :: sicfile -character*(max_path_len), public :: userfile -character*(max_path_len), public :: sstfile -character*(max_path_len), public :: lsmpftfile -character*(max_path_len), public :: pressfile -character*(max_path_len), public :: topofile -character*(max_path_len), public :: ozonefile -character*(max_path_len), public :: iopfile -character*(max_path_len), public :: absemsfile -character*(max_path_len), public :: aermassfile -character*(max_path_len), public :: aeropticsfile -character*(max_path_len), public :: timeinvfile -character*(max_path_len), public :: lsmsurffile -character*(max_path_len), public :: lsminifile +integer :: bdate, last_date, last_sec + +character(len=max_path_len), public :: modelfile +character(len=max_path_len), public :: analysisfile +character(len=max_path_len), public :: sicfile +character(len=max_path_len), public :: userfile +character(len=max_path_len), public :: sstfile +character(len=max_path_len), public :: lsmpftfile +character(len=max_path_len), public :: pressfile +character(len=max_path_len), public :: topofile +character(len=max_path_len), public :: ozonefile +character(len=max_path_len), public :: iopfile +character(len=max_path_len), public :: absemsfile +character(len=max_path_len), public :: aermassfile +character(len=max_path_len), public :: aeropticsfile +character(len=max_path_len), public :: timeinvfile +character(len=max_path_len), public :: lsmsurffile +character(len=max_path_len), public :: lsminifile ! note that scm_zadv_q is set to slt to be consistent with CAM BFB testing @@ -169,7 +170,7 @@ module scamMod logical, public :: doiopupdate = .false. ! do we need to read next iop timepoint logical, public :: have_lhflx = .false. ! dataset contains lhflx logical, public :: have_shflx = .false. ! dataset contains shflx -logical, public :: have_heat_glob = .false. ! dataset contains shflx +logical, public :: have_heat_glob = .false. ! dataset contains heat total logical, public :: have_tg = .false. ! dataset contains tg logical, public :: have_tsair = .false. ! dataset contains tsair logical, public :: have_divq = .false. ! dataset contains divq @@ -219,9 +220,9 @@ module scamMod logical, public :: scm_force_latlon = .false. ! force scam to use the lat lon fields specified in the namelist not closest real(r8), public :: scm_relaxation_low ! lowest level to apply relaxation real(r8), public :: scm_relaxation_high ! highest level to apply relaxation -real(r8), public :: scm_relax_top_p = 1.e36_r8 ! upper bound for scm relaxation -real(r8), public :: scm_relax_bot_p = -1.e36_r8 ! lower bound for scm relaxation -real(r8), public :: scm_relax_tau_sec = 10800._r8 ! relaxation time constant (sec) +real(r8), public :: scm_relax_top_p = 0._r8 ! upper bound for scm relaxation +real(r8), public :: scm_relax_bot_p = huge(1._r8) ! lower bound for scm relaxation +real(r8), public :: scm_relax_tau_sec = 10800._r8 ! relaxation time constant (sec) ! +++BPM: ! modification... allow a linear ramp in relaxation time scale: @@ -236,7 +237,7 @@ module scamMod logical, public :: scm_use_obs_uv = .true. ! Use the SCAM-IOP observed u,v at each time step instead of forecasting. -logical, public :: scm_use_obs_qv = .false. ! Use the SCAM-IOPobserved qv at each time step instead of forecasting. +logical, public :: scm_use_obs_qv = .false. ! Use the SCAM-IOP observed qv at each time step instead of forecasting. logical, public :: scm_use_3dfrc = .false. ! Use CAMIOP 3d forcing if true, else use dycore vertical plus horizontal logical, public :: scm_iop_lhflxshflxTg = .false. !turn off LW rad logical, public :: scm_iop_Tg = .false. !turn off LW rad @@ -401,14 +402,10 @@ subroutine readiopdata(hvcoord) use hybvcoord_mod, only: hvcoord_t use getinterpnetcdfdata, only: getinterpncdata use shr_sys_mod, only: shr_sys_flush - use error_messages, only: handle_ncerr use string_utils, only: to_lower use wrap_nf, only: wrap_inq_dimid,wrap_get_vara_realx !----------------------------------------------------------------------- implicit none -#if ( defined RS6000 ) - implicit automatic ( a-z ) -#endif character(len=*), parameter :: sub = "read_iop_data" ! @@ -418,32 +415,33 @@ subroutine readiopdata(hvcoord) ! !------------------------------Locals----------------------------------- ! - integer NCID, status - integer time_dimID, lev_dimID, lev_varID, varid - integer i,j - integer nlev - integer total_levs - integer u_attlen - - integer k, m - integer icldliq,icldice - integer inumliq,inumice - - logical have_srf ! value at surface is available - logical fill_ends ! - logical have_cnst(pcnst) - real(r8) dummy - real(r8) srf(1) ! value at surface - real(r8) hyam(plev),hybm(plev) - real(r8) pmid(plev) ! pressure at model levels (time n) - real(r8) pint(plevp) ! pressure at model interfaces (n ) - real(r8) pdel(plev) ! pdel(k) = pint (k+1)-pint (k) - real(r8) weight - real(r8) tmpdata(1) - real(r8) coldata(plev) + integer :: NCID, status + integer :: time_dimID, lev_dimID, lev_varID, varid + integer :: i,j + integer :: nlev + integer :: total_levs + integer :: u_attlen + + integer :: k, m + integer :: icldliq,icldice + integer :: inumliq,inumice + + logical :: have_srf ! value at surface is available + logical :: fill_ends ! + logical :: have_cnst(pcnst) + real(r8) :: dummy + real(r8) :: srf(1) ! value at surface + real(r8) :: hyam(plev),hybm(plev) + real(r8) :: pmid(plev) ! pressure at model levels (time n) + real(r8) :: pint(plevp) ! pressure at model interfaces (n ) + real(r8) :: pdel(plev) ! pdel(k) = pint (k+1)-pint (k) + real(r8) :: weight + real(r8) :: tmpdata(1) + real(r8) :: coldata(plev) real(r8), allocatable :: dplevs( : ) - integer strt4(4),cnt4(4) - integer nstep + integer :: strt4(4),cnt4(4) + integer :: nstep + integer :: ios character(len=128) :: units ! Units nstep = get_nstep() @@ -452,8 +450,8 @@ subroutine readiopdata(hvcoord) ! ! Open IOP dataset ! - call handle_ncerr( nf90_open (iopfile, 0, ncid),& - 'readiopdata.F90', __LINE__) + call handle_ncerr( nf90_open (iopfile, 0, ncid),& + 'ERROR - scamMod.F90:readiopdata', __LINE__) ! ! if the dataset is a CAM generated dataset set use_camiop to true @@ -474,14 +472,14 @@ subroutine readiopdata(hvcoord) if (status /= NF90_NOERR) then status = nf90_inq_dimid (ncid, 'tsec', time_dimID ) if (status /= NF90_NOERR) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find dimension ID for time/tsec' + if (masterproc) write(iulog,*) sub//':ERROR - Could not find dimension ID for time/tsec' status = NF90_CLOSE ( ncid ) call endrun end if end if call handle_ncerr( nf90_inquire_dimension( ncid, time_dimID, len=ntime ),& - 'readiopdata.F90', __LINE__) + 'Error - scamMod.F90:readiopdata unable to find time dimension', __LINE__) ! !====================================================== @@ -489,32 +487,36 @@ subroutine readiopdata(hvcoord) ! status = NF90_INQ_DIMID( ncid, 'lev', lev_dimID ) if ( status /= nf90_noerr ) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable dim ID for lev' + if (masterproc) write(iulog,*) sub//':ERROR - Could not find variable dim ID for lev' status = NF90_CLOSE ( ncid ) - return + call endrun(sub // ':ERROR - Could not find variable dim ID for lev') end if call handle_ncerr( nf90_inquire_dimension( ncid, lev_dimID, len=nlev ),& - 'readiopdata.F90', __LINE__) + 'Error - scamMod.f90:readiopdata unable to find level dimension', __LINE__) - allocate(dplevs(nlev+1)) + allocate(dplevs(nlev+1),stat=ios) + if( ios /= 0 ) then + write(iulog,*) sub//':ERROR: failed to allocate dplevs; error = ',ios + call endrun('ERROR:readiopdata failed to allocate dplevs') + end if status = NF90_INQ_VARID( ncid, 'lev', lev_varID ) if ( status /= nf90_noerr ) then - if (masterproc) write(iulog,*) sub//':ERROR - readiopdata.F:Could not find variable ID for lev' + if (masterproc) write(iulog,*) sub//':ERROR - scamMod.F90:readiopdata:Could not find variable ID for lev' status = NF90_CLOSE ( ncid ) - return + call endrun end if call handle_ncerr( nf90_get_var (ncid, lev_varID, dplevs(:nlev)),& - 'readiopdata.F90', __LINE__) + 'Error - scamMod.F90:readiopdata unable to read pressure levels', __LINE__) ! !CAM generated forcing already has pressure on millibars convert standard IOP if needed. ! call handle_ncerr(nf90_inquire_attribute(ncid, lev_varID, 'units', len=u_attlen),& - 'readiopdata.F90', __LINE__) + 'Error - scamMod.F90:readiopdata unable to find units attribute', __LINE__) call handle_ncerr(nf90_get_att(ncid, lev_varID, 'units', units),& - 'readiopdata.F90', __LINE__) + 'Error - scamMod.F90:readiopdata unable to read units attribute', __LINE__) units=trim(to_lower(units(1:u_attlen))) if ( units=='pa' .or. units=='pascal' .or. units=='pascals' ) then @@ -574,7 +576,7 @@ subroutine readiopdata(hvcoord) nlev = total_levs endif if ( nlev == 1 ) then - if (masterproc) write(iulog,*) sub//':Error - Readiopdata.F: Ps too low!' + if (masterproc) write(iulog,*) sub//':Error - scamMod.F90:readiopdata: Ps too low!' return endif @@ -623,7 +625,7 @@ subroutine readiopdata(hvcoord) if (is_first_step()) write(iulog,*)'using column value of soltsi from boundary data as global solar tsi' end if !===================================================================== -!get global vmrs from camiop file +!get state variables from camiop file status = nf90_inq_varid( ncid, 'Tsair', varid ) if ( status /= nf90_noerr ) then @@ -1055,7 +1057,6 @@ subroutine readiopdata(hvcoord) have_omega = .true. endif call plevs0(plev ,psobs ,pint,pmid ,pdel, hvcoord) - call shr_sys_flush( iulog ) ! ! Build interface vector for the specified omega profile ! (weighted average in pressure of specified level values) @@ -1106,7 +1107,6 @@ subroutine readiopdata(hvcoord) else have_v = .true. endif - call shr_sys_flush( iulog ) status = nf90_inq_varid( ncid, 'Prec', varid ) if ( status /= nf90_noerr ) then @@ -1174,7 +1174,6 @@ subroutine readiopdata(hvcoord) have_shflx = .true. endif - call shr_sys_flush( iulog ) ! If REPLAY is used, then need to read in the global ! energy fixer status = nf90_inq_varid( ncid, 'heat_glob', varid ) @@ -1217,8 +1216,6 @@ subroutine readiopdata(hvcoord) endif endif - call shr_sys_flush( iulog ) - status = nf90_inq_varid( ncid, 'beta', varid ) if ( status /= nf90_noerr ) then betacam = 0._r8 @@ -1238,13 +1235,11 @@ subroutine readiopdata(hvcoord) endif call shr_sys_flush( iulog ) - status = nf90_close( ncid ) call shr_sys_flush( iulog ) deallocate(dplevs) - return end subroutine readiopdata subroutine setiopupdate @@ -1259,14 +1254,12 @@ subroutine setiopupdate ! !----------------------------------------------------------------------- implicit none -#if ( defined RS6000 ) - implicit automatic (a-z) -#endif - character(len=*), parameter :: sub = "setiopupdate" + + character(len=*), parameter :: sub = "setiopupdate" !------------------------------Locals----------------------------------- - integer next_date, next_sec + integer :: next_date, next_sec integer :: ncsec,ncdate ! current time of day,date integer :: yr, mon, day ! year, month, and day component !------------------------------------------------------------------------------ @@ -1309,7 +1302,7 @@ subroutine setiopupdate if ( ncdate > last_date .or. (ncdate == last_date & .and. ncsec > last_sec)) then if ( .not. scm_backfill_iop_w_init ) then - call endrun(sub//':ERROR - setiopupdate.c:Reached the end of the time varient dataset') + call endrun(sub//':ERROR: Reached the end of the time varient dataset') else doiopupdate = .false. end if @@ -1319,8 +1312,6 @@ subroutine setiopupdate if (masterproc) write(iulog,*) sub//':iop time index = ' , ioptimeidx #endif - return - end subroutine setiopupdate !=============================================================================== @@ -1333,15 +1324,8 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) ! Define the pressures of the interfaces and midpoints from the ! coordinate definitions and the surface pressure. ! -! Method: -! ! Author: B. Boville ! -!----------------------------------------------------------------------- -! -! $Id$ -! $Author$ -! !----------------------------------------------------------------------- use hybvcoord_mod, only : hvcoord_t @@ -1358,7 +1342,7 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) !----------------------------------------------------------------------- !---------------------------Local workspace----------------------------- - integer k ! Longitude, level indices + integer :: k ! Longitude, level indices !----------------------------------------------------------------------- ! ! Set interface pressures @@ -1376,7 +1360,6 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) pdel(k) = pint(k+1) - pint(k) end do - return end subroutine plevs0 subroutine scmiop_flbc_inti ( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) @@ -1385,15 +1368,6 @@ subroutine scmiop_flbc_inti ( co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr ) ! Purpose: ! Get start count for variable ! - ! Method: - ! - ! Author: - ! - !----------------------------------------------------------------------- - ! - ! $Id$ - ! $Author$ - ! !----------------------------------------------------------------------- implicit none @@ -1416,19 +1390,11 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , ! Purpose: ! set global lower boundary conditions ! - ! Method: - ! - ! Author: - ! - !----------------------------------------------------------------------- - ! - ! $Id$ - ! $Author$ - ! !----------------------------------------------------------------------- implicit none + character(len=*), parameter :: sub = "get_start_count" !----------------------------------------------------------------------- integer , intent(in) :: ncid ! file id @@ -1438,12 +1404,12 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , integer , intent(out) :: start(:),count(:) !---------------------------Local workspace----------------------------- - integer dims_set,nlev,var_ndims - logical usable_var - character dim_name*( 256 ) - integer var_dimIDs( NF90_MAX_VAR_DIMS ) - real(r8) closelat,closelon - integer latidx,lonidx,status,i + integer :: dims_set,nlev,var_ndims + logical :: usable_var + character(len=256) :: dim_name + integer :: var_dimIDs( NF90_MAX_VAR_DIMS ) + real(r8) :: closelat,closelon + integer :: latidx,lonidx,status,i !----------------------------------------------------------------------- call shr_scam_GetCloseLatLon(ncid,scmlat,scmlon,closelat,closelon,latidx,lonidx) @@ -1453,14 +1419,13 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , ! surface variables ! if ( var_ndims == 0 ) then - call endrun('SCAMMOD: var_ndims is 0 for varid:',varid) - return + call endrun(sub//':ERROR: var_ndims is 0 for varid:',varid) endif STATUS = NF90_INQUIRE_VARIABLE( NCID, varID, dimids=var_dimIDs) if ( STATUS /= NF90_NOERR ) then - write(iulog,* ) 'ERROR - extractdata.F:Cant get dimension IDs for varid', varid - return + write(iulog,* ) sub//'ERROR - Cant get dimension IDs for varid', varid + call endrun(sub//':ERROR: Cant get dimension IDs for varid',varid) endif ! ! Initialize the start and count arrays @@ -1509,7 +1474,6 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , usable_var = .true. endif end do - return end subroutine get_start_count !========================================================================= @@ -1527,66 +1491,72 @@ subroutine setiopupdate_init ! !----------------------------------------------------------------------- implicit none -#if ( defined RS6000 ) - implicit automatic (a-z) -#endif !------------------------------Locals----------------------------------- - integer NCID,i - integer tsec_varID, time_dimID - integer bdate_varID - integer STATUS - integer next_date, next_sec + integer :: NCID,i + integer :: tsec_varID, time_dimID + integer :: bdate_varID + integer :: STATUS + integer :: next_date, next_sec integer :: ncsec,ncdate ! current time of day,date integer :: yr, mon, day ! year, month, and day component integer :: start_ymd,start_tod -!------------------------------------------------------------------------------ - ! Open and read pertinent information from the IOP file + character(len=*), parameter :: sub = "setiopupdate_init" +!!------------------------------------------------------------------------------ + + ! Open and read pertinent information from the IOP file - STATUS = NF90_OPEN( iopfile, NF90_NOWRITE, NCID ) + call handle_ncerr( nf90_open (iopfile, 0, ncid),& + 'ERROR - scamMod.F90:setiopupdate_init Failed to open iop file', __LINE__) - ! Read time (tsec) variable + ! Read time (tsec) variable STATUS = NF90_INQ_VARID( NCID, 'tsec', tsec_varID ) - if ( STATUS /= NF90_NOERR ) write(iulog,*)'ERROR - setiopupdate.F:', & - 'Cant get variable ID for tsec' + if ( STATUS /= NF90_NOERR ) then + write(iulog,*)sub//':ERROR: Cant get variable ID for tsec' + STATUS = NF90_CLOSE ( NCID ) + call endrun(sub//':ERROR: Cant get variable ID for tsec') + end if STATUS = NF90_INQ_VARID( NCID, 'bdate', bdate_varID ) if ( STATUS /= NF90_NOERR ) then STATUS = NF90_INQ_VARID( NCID, 'basedate', bdate_varID ) - if ( STATUS /= NF90_NOERR ) & - write(iulog,*)'ERROR - setiopupdate.F:Cant get variable ID for bdate' + if ( STATUS /= NF90_NOERR ) then + write(iulog,*)'ERROR - setiopupdate:Cant get variable ID for base date' + STATUS = NF90_CLOSE ( NCID ) + call endrun(sub//':ERROR: Cant get variable ID for base date') + endif endif STATUS = NF90_INQ_DIMID( NCID, 'time', time_dimID ) if ( STATUS /= NF90_NOERR ) then STATUS = NF90_INQ_DIMID( NCID, 'tsec', time_dimID ) if ( STATUS /= NF90_NOERR ) then - write(iulog,* )'ERROR - setiopupdate.F:Could not find variable dim ID for time' + write(iulog,* )'ERROR - setiopupdate:Could not find variable dim ID for time' STATUS = NF90_CLOSE ( NCID ) - return + call endrun(sub//':ERROR:Could not find variable dim ID for time') end if end if if ( STATUS /= NF90_NOERR ) & - write(iulog,*)'ERROR - setiopupdate.F:Cant get variable dim ID for time' + write(iulog,*)'ERROR - setiopupdate:Cant get variable dim ID for time' STATUS = NF90_INQUIRE_DIMENSION( NCID, time_dimID, len=ntime ) if ( STATUS /= NF90_NOERR )then - write(iulog,*)'ERROR - setiopupdate.F:Cant get time dimlen' + write(iulog,*)'ERROR - setiopupdate:Cant get time dimlen' endif if (.not.allocated(tsec)) allocate(tsec(ntime)) STATUS = NF90_GET_VAR( NCID, tsec_varID, tsec ) if ( STATUS /= NF90_NOERR )then - write(iulog,*)'ERROR - setiopupdate.F:Cant get variable tsec' + write(iulog,*)'ERROR - setiopupdate:Cant get variable tsec' endif STATUS = NF90_GET_VAR( NCID, bdate_varID, bdate ) if ( STATUS /= NF90_NOERR )then - write(iulog,*)'ERROR - setiopupdate.F:Cant get variable bdate' + write(iulog,*)'ERROR - setiopupdate:Cant get variable bdate' endif ! Close the netCDF file @@ -1618,7 +1588,7 @@ subroutine setiopupdate_init write(iulog,*) ' Current CAM Date is ',ncdate,' and ',ncsec,' seconds' write(iulog,*) ' IOP start is ',next_date,' and ',next_sec,'seconds' write(iulog,*) ' IOP end is ',last_date,' and ',last_sec,'seconds' - call endrun + call endrun(sub//':ERROR: Current model time does not fall within IOP period') endif doiopupdate = .true. diff --git a/src/dynamics/se/advect_tend.F90 b/src/dynamics/se/advect_tend.F90 index 31cba03435..815bc51135 100644 --- a/src/dynamics/se/advect_tend.F90 +++ b/src/dynamics/se/advect_tend.F90 @@ -91,13 +91,14 @@ subroutine compute_adv_tends_xyz(elem,fvm,nets,nete,qn0,n0) end subroutine compute_adv_tends_xyz !---------------------------------------------------------------------- - ! computes camiop specific tendencies and + ! computes camiop specific tendencies ! and writes these to the camiop file ! called twice each time step: ! - first call sets the initial mixing ratios/state ! - second call computes and outputs the tendencies !---------------------------------------------------------------------- subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) + use cam_abortutils, only: endrun use cam_history, only: outfld, hist_fld_active use time_manager, only: get_step_size use constituents, only: pcnst,cnst_name @@ -120,7 +121,9 @@ subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) real(r8), allocatable :: out_ps(:) integer :: i,j,ic,nx,ie,nxsq,p + integer :: ierr logical :: init + character(len=*), parameter :: sub = 'compute_write_iop_fields:' !---------------------------------------------------------------------------- if (use_cslam) then @@ -136,19 +139,24 @@ subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) if ( .not. allocated( iop_qtendxyz ) ) then init = .true. - allocate( iop_qtendxyz(nx,nx,nlev,pcnst,nets:nete) ) + allocate( iop_qtendxyz(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_qtendxyz' ) iop_qtendxyz = 0._r8 - allocate( derivedfq(nx,nx,nlev,pcnst,nets:nete) ) + allocate( derivedfq(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate derivedfq' ) derivedfq = 0._r8 - allocate( iop_qtendxyz_init(nx,nx,nlev,pcnst,nets:nete) ) + allocate( iop_qtendxyz_init(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate ipo_qtendxyz' ) iop_qtendxyz_init = 0._r8 - allocate( iop_ttendxyz(nx,nx,nlev,nets:nete) ) + allocate( iop_ttendxyz(nx,nx,nlev,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_ttendxyz' ) iop_ttendxyz = 0._r8 - allocate( iop_ttendxyz_init(nx,nx,nlev,nets:nete) ) + allocate( iop_ttendxyz_init(nx,nx,nlev,nets:nete),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_ttendxyz_init' ) iop_ttendxyz_init = 0._r8 endif - ! save inital/calc tendencies on second call to this routine. + ! save initial/calc tendencies on second call to this routine. if (use_cslam) then do ie=nets,nete do ic=1,pcnst @@ -175,21 +183,29 @@ subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) end if if ( .not. init ) then - allocate( q_adv(nxsq,nlev,pcnst) ) + allocate( q_adv(nxsq,nlev,pcnst),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate q_adv' ) q_adv = 0._r8 - allocate( t_adv(npsq,nlev) ) + allocate( t_adv(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate t_adv' ) t_adv = 0._r8 - allocate( q_new(nx,nx,nlev) ) + allocate( q_new(nx,nx,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate q_new' ) q_new = 0._r8 - allocate( out_q(npsq,nlev) ) + allocate( out_q(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_q' ) out_q = 0._r8 - allocate( out_t(npsq,nlev) ) + allocate( out_t(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_t' ) out_t = 0._r8 - allocate( out_u(npsq,nlev) ) + allocate( out_u(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_u' ) out_u = 0._r8 - allocate( out_v(npsq,nlev) ) + allocate( out_v(npsq,nlev),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_v' ) out_v = 0._r8 - allocate( out_ps(npsq) ) + allocate( out_ps(npsq),stat=ierr ) + if (ierr/=0) call endrun( sub//': not able to allocate out_ps' ) out_ps = 0._r8 do ie=nets,nete do j=1,nx diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index a7a6da2532..dbb52ac1cb 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -48,7 +48,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In real(r8), intent(in) :: t_in(plev) ! temperature [K] real(r8), intent(in) :: q_in(plev,pcnst) ! q tracer array [units vary] already vertically advected real(r8), intent(in) :: t_phys_frc(plev) ! temperature forcing from physics [K/s] - real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! temperature forcing from physics [K/s] + real(r8), intent(in) :: q_phys_frc(plev,pcnst) ! change in q due to physics. type (hvcoord_t), intent(in) :: hvcoord real(r8), intent(in) :: scm_dt ! model time step [s] @@ -183,12 +183,11 @@ subroutine advance_iop_nudging(ztodt, ps_in, & ! In ! scm_relaxation is a logical from scamMod ! scm_relax_tau_top_sec and scm_relax_tau_bot_sec are the relaxation times at top and bottom of layer ! also defined in scamMod - if ( scm_relaxation.and.scm_relax_linear ) then + if ( scm_relax_linear ) then rslope = (scm_relax_top_p - scm_relax_bot_p)/(scm_relax_tau_top_sec - scm_relax_tau_bot_sec) rycept = scm_relax_tau_top_sec - (rslope*scm_relax_top_p) endif - ! prepare scm_relax_fincl for comparison in scmforecast.F90 scm_fincl_empty=.true. do i=1,pcnst if (len_trim(scm_relax_fincl(i)) > 0) then @@ -198,40 +197,38 @@ subroutine advance_iop_nudging(ztodt, ps_in, & ! In end do do k = 1, plev - if( scm_relaxation ) then - if ( pmidm1(k) <= scm_relax_bot_p.and.pmidm1(k) >= scm_relax_top_p ) then ! inside layer - if (scm_relax_linear) then - rtau(k) = rslope*pmidm1(k) + rycept ! linear regime - else - rtau(k) = max( ztodt, scm_relax_tau_sec ) ! constant for whole layer / no relax outside - endif - else if (scm_relax_linear .and. pmidm1(k) <= scm_relax_top_p ) then ! not linear => do nothing / linear => use upper value - rtau(k) = scm_relax_tau_top_sec ! above layer keep rtau equal to the top + if ( pmidm1(k) <= scm_relax_bot_p.and.pmidm1(k) >= scm_relax_top_p ) then ! inside layer + if (scm_relax_linear) then + rtau(k) = rslope*pmidm1(k) + rycept ! linear regime + else + rtau(k) = max( ztodt, scm_relax_tau_sec ) ! constant for whole layer / no relax outside endif - ! +BPM: this can't be the best way... - ! I put this in because if rtau doesn't get set above, then I don't want to do any relaxation in that layer. - ! maybe the logic of this whole loop needs to be re-thinked. - if (rtau(k) /= 0) then - relax_T(k) = - ( tfcst(k) - tobs(k) ) / rtau(k) - relax_u(k) = - ( ufcst(k) - uobs(k) ) / rtau(k) - relax_v(k) = - ( vfcst(k) - vobs(k) ) / rtau(k) - relax_q(k,1) = - ( qfcst(1,k,1) - qobs(k) ) / rtau(k) - do m = 2, pcnst - relax_q(k,m) = - ( qfcst(1,k,m) - qinitobs(k,m) ) / rtau(k) - enddo - if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == 'T')) & - tfcst(k) = tfcst(k) + relax_T(k) * ztodt - if (scm_fincl_empty .or.ANY(scm_relax_fincl(:) == 'U')) & - ufcst(k) = ufcst(k) + relax_u(k) * ztodt - if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == 'V')) & - vfcst(k) = vfcst(k) + relax_v(k) * ztodt - do m = 1, pcnst - if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == trim(to_upper(cnst_name(m)))) ) then - qfcst(1,k,m) = qfcst(1,k,m) + relax_q(k,m) * ztodt - end if - enddo - end if + else if (scm_relax_linear .and. pmidm1(k) <= scm_relax_top_p ) then ! not linear => do nothing / linear => use upper value + rtau(k) = scm_relax_tau_top_sec ! above layer keep rtau equal to the top endif + ! +BPM: this can't be the best way... + ! I put this in because if rtau doesn't get set above, then I don't want to do any relaxation in that layer. + ! maybe the logic of this whole loop needs to be re-thinked. + if (rtau(k) /= 0) then + relax_T(k) = - ( tfcst(k) - tobs(k) ) / rtau(k) + relax_u(k) = - ( ufcst(k) - uobs(k) ) / rtau(k) + relax_v(k) = - ( vfcst(k) - vobs(k) ) / rtau(k) + relax_q(k,1) = - ( qfcst(1,k,1) - qobs(k) ) / rtau(k) + do m = 2, pcnst + relax_q(k,m) = - ( qfcst(1,k,m) - qinitobs(k,m) ) / rtau(k) + enddo + if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == 'T')) & + tfcst(k) = tfcst(k) + relax_T(k) * ztodt + if (scm_fincl_empty .or.ANY(scm_relax_fincl(:) == 'U')) & + ufcst(k) = ufcst(k) + relax_u(k) * ztodt + if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == 'V')) & + vfcst(k) = vfcst(k) + relax_v(k) * ztodt + do m = 1, pcnst + if (scm_fincl_empty .or. ANY(scm_relax_fincl(:) == trim(to_upper(cnst_name(m)))) ) then + qfcst(1,k,m) = qfcst(1,k,m) + relax_q(k,m) * ztodt + end if + enddo + end if enddo end subroutine advance_iop_nudging diff --git a/src/dynamics/se/dycore/prim_driver_mod.F90 b/src/dynamics/se/dycore/prim_driver_mod.F90 index 3f8d1749c9..c291aff623 100644 --- a/src/dynamics/se/dycore/prim_driver_mod.F90 +++ b/src/dynamics/se/dycore/prim_driver_mod.F90 @@ -290,10 +290,10 @@ subroutine prim_run_subcycle(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,nsubst if (r.ne.1) call TimeLevel_update(tl,"leapfrog") if (single_column) then ! Single Column Case - ! Loop over rsplit vertically lagrangian timesiteps + ! Loop over rsplit vertically lagrangian timesteps call prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) else - ! Loop over rsplit vertically lagrangian timesiteps + ! Loop over rsplit vertically lagrangian timesteps call prim_step(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord,r) end if enddo @@ -692,7 +692,7 @@ subroutine prim_step_scm(elem, fvm, hybrid,nets,nete, dt, tl, hvcoord, rstep) hybrid, dt, tl, nets, nete) call t_stopf('set_prescribed_scm') - enddo + enddo end subroutine prim_step_scm !=======================================================================================================! diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index cd8e56f2d1..f6b19f09b4 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -239,7 +239,7 @@ end subroutine apply_SC_forcing subroutine iop_broadcast() !--------------------------------------------------------- - ! Purpose: When running DP-CRM, broadcast relevant logical + ! Purpose: Broadcast relevant logical ! flags and data to all processors !---------------------------------------------------------- @@ -320,8 +320,8 @@ end subroutine iop_broadcast subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) !--------------------------------------------------------- - ! Purpose: When running DP-CRM, broadcast relevant logical - ! flags and data to all processors + ! Purpose: Determine closest column index in the IOP file + ! based on the input scm latitude and longitude !---------------------------------------------------------- use shr_const_mod, only: pi => SHR_CONST_PI @@ -335,6 +335,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) real(r8) :: scmposlon, minpoint, testlat, testlon, testval integer :: ierr real(r8), parameter :: rad2deg = 180.0_r8 / pi + character(len=*), parameter :: sub = 'scm_dyn_grid_indicies' ie_scm=0 i_scm=0 @@ -364,7 +365,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) enddo if (ie_scm == 0 .or. i_scm == 0 .or. j_scm == 0 .or. indx_scm == 0) then - call endrun('Could not find closest SCM point on input datafile') + call endrun(sub//':FATAL: Could not find closest SCM point on input datafile') endif end subroutine scm_dyn_grid_indicies From 0407135764f59de4c35b5e6535d808c71d9e7641 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 19 Apr 2024 14:23:45 -0600 Subject: [PATCH 21/75] PR updates --- bld/namelist_files/namelist_defaults_cam.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index d8fe71c93c..3560d435d8 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -3010,7 +3010,7 @@ 1 1 - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc atm/cam/inic/gaus/CESM2.F2000climo.64x128.cam.i.0003-06-01-00000.nc atm/cam/scam/iop/ARM97_4scam.nc From 551612d501ce7080ee7b53fae4cd11c008479a95 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 19 Apr 2024 17:06:57 -0600 Subject: [PATCH 22/75] PR updates --- src/control/scamMod.F90 | 50 +++++++++++++++++------------------------ 1 file changed, 20 insertions(+), 30 deletions(-) diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index cfbcf8d78c..44a3a45cc2 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -401,7 +401,6 @@ subroutine readiopdata(hvcoord) !----------------------------------------------------------------------- use hybvcoord_mod, only: hvcoord_t use getinterpnetcdfdata, only: getinterpncdata - use shr_sys_mod, only: shr_sys_flush use string_utils, only: to_lower use wrap_nf, only: wrap_inq_dimid,wrap_get_vara_realx !----------------------------------------------------------------------- @@ -474,7 +473,7 @@ subroutine readiopdata(hvcoord) if (status /= NF90_NOERR) then if (masterproc) write(iulog,*) sub//':ERROR - Could not find dimension ID for time/tsec' status = NF90_CLOSE ( ncid ) - call endrun + call endrun(sub // ':ERROR - time/tsec must be present on the IOP file.') end if end if @@ -498,14 +497,14 @@ subroutine readiopdata(hvcoord) allocate(dplevs(nlev+1),stat=ios) if( ios /= 0 ) then write(iulog,*) sub//':ERROR: failed to allocate dplevs; error = ',ios - call endrun('ERROR:readiopdata failed to allocate dplevs') + call endrun(sub//':ERROR:readiopdata failed to allocate dplevs') end if status = NF90_INQ_VARID( ncid, 'lev', lev_varID ) if ( status /= nf90_noerr ) then if (masterproc) write(iulog,*) sub//':ERROR - scamMod.F90:readiopdata:Could not find variable ID for lev' status = NF90_CLOSE ( ncid ) - call endrun + call endrun(sub//':ERROR:ould not find variable ID for lev') end if call handle_ncerr( nf90_get_var (ncid, lev_varID, dplevs(:nlev)),& @@ -530,13 +529,13 @@ subroutine readiopdata(hvcoord) status = nf90_inq_varid( ncid, 'Ps', varid ) if ( status /= nf90_noerr ) then - have_ps = .false. + have_ps= .false. if (masterproc) write(iulog,*) sub//':Could not find variable Ps' if ( .not. scm_backfill_iop_w_init ) then status = NF90_CLOSE( ncid ) - return + call endrun(sub//':ERROR :IOP file must contain Surface Pressure (Ps) variable') else - if ( is_first_step() .and. masterproc) write(iulog,*) 'Using pressure value from Analysis Dataset' + if ( is_first_step() .and. masterproc) write(iulog,*) 'Using surface pressure value from IC file if present' endif else call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) @@ -577,7 +576,7 @@ subroutine readiopdata(hvcoord) endif if ( nlev == 1 ) then if (masterproc) write(iulog,*) sub//':Error - scamMod.F90:readiopdata: Ps too low!' - return + call endrun(sub//':ERROR:Ps value on datasets is incongurent with levs data - mismatch in units?') endif !===================================================================== @@ -652,12 +651,11 @@ subroutine readiopdata(hvcoord) endif if ( status /= nf90_noerr ) then have_t = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable T' - if ( .not. scm_backfill_iop_w_init ) then - status = NF90_CLOSE( ncid ) - return + if (masterproc) write(iulog,*) sub//':Could not find variable T on IOP file' + if ( scm_backfill_iop_w_init ) then + if (masterproc) write(iulog,*) sub//':Using value of T(tobs) from IC file if it exists' else - if (masterproc) write(iulog,*) sub//':Using value from Analysis Dataset' + if (masterproc) write(iulog,*) sub//':set tobs to 0.' endif ! ! set T3 to Tobs on first time step @@ -700,12 +698,11 @@ subroutine readiopdata(hvcoord) dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, qobs, status ) if ( status /= nf90_noerr ) then have_q = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable q' - if ( .not. scm_backfill_iop_w_init ) then - status = nf90_close( ncid ) - return + if (masterproc) write(iulog,*) sub//':Could not find variable q on IOP file' + if ( scm_backfill_iop_w_init ) then + if (masterproc) write(iulog,*) sub//':Using values for q from IC file if available' else - if (masterproc) write(iulog,*) sub//':Using values from Analysis Dataset' + if (masterproc) write(iulog,*) sub//':Setting qobs to 0.' endif else have_q = .true. @@ -1046,12 +1043,11 @@ subroutine readiopdata(hvcoord) dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, wfld, status ) if ( status /= nf90_noerr ) then have_omega = .false. - if (masterproc) write(iulog,*) sub//':Could not find variable omega' - if ( .not. scm_backfill_iop_w_init ) then - status = nf90_close( ncid ) - return + if (masterproc) write(iulog,*) sub//':Could not find variable omega on IOP' + if ( scm_backfill_iop_w_init ) then + if (masterproc) write(iulog,*) sub//'Using omega from IC file' else - if (masterproc) write(iulog,*) sub//'Using value from Analysis Dataset' + if (masterproc) write(iulog,*) sub//'setting Omega to 0. throughout the column' endif else have_omega = .true. @@ -1234,9 +1230,7 @@ subroutine readiopdata(hvcoord) fixmascam=srf(1) endif - call shr_sys_flush( iulog ) status = nf90_close( ncid ) - call shr_sys_flush( iulog ) deallocate(dplevs) @@ -1301,11 +1295,7 @@ subroutine setiopupdate ! if ( ncdate > last_date .or. (ncdate == last_date & .and. ncsec > last_sec)) then - if ( .not. scm_backfill_iop_w_init ) then - call endrun(sub//':ERROR: Reached the end of the time varient dataset') - else - doiopupdate = .false. - end if + call endrun(sub//':ERROR: Reached the end of the time varient dataset') endif #if DEBUG > 1 From 5d10dfd8373fc59b23594f140c30bcbf62c60ec3 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 30 Apr 2024 00:24:20 -0600 Subject: [PATCH 23/75] dadadj ccpp updates --- bld/configure | 1 + src/control/cam_snapshot_common.F90 | 2 +- src/physics/cam/dadadj.F90 | 174 ---------------------------- src/physics/cam/dadadj_cam.F90 | 98 +++++++++------- src/physics/cam/physpkg.F90 | 4 +- src/physics/cam_dev/physpkg.F90 | 4 +- 6 files changed, 61 insertions(+), 222 deletions(-) delete mode 100644 src/physics/cam/dadadj.F90 diff --git a/bld/configure b/bld/configure index e2fb784495..05f1d7155c 100755 --- a/bld/configure +++ b/bld/configure @@ -2304,6 +2304,7 @@ sub write_filepath #Add the CCPP'ized subdirectories print $fh "$camsrcdir/src/atmos_phys/zhang_mcfarlane\n"; + print $fh "$camsrcdir/src/atmos_phys/dadadj\n"; # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; diff --git a/src/control/cam_snapshot_common.F90 b/src/control/cam_snapshot_common.F90 index f2a4780619..81e8694006 100644 --- a/src/control/cam_snapshot_common.F90 +++ b/src/control/cam_snapshot_common.F90 @@ -86,7 +86,7 @@ module cam_snapshot_common type (snapshot_type) :: tend_snapshot(6) type (snapshot_type) :: cam_in_snapshot(30) type (snapshot_type) :: cam_out_snapshot(30) -type (snapshot_type_nd) :: pbuf_snapshot(250) +type (snapshot_type_nd) :: pbuf_snapshot(300) contains diff --git a/src/physics/cam/dadadj.F90 b/src/physics/cam/dadadj.F90 deleted file mode 100644 index b9762f8f5f..0000000000 --- a/src/physics/cam/dadadj.F90 +++ /dev/null @@ -1,174 +0,0 @@ -module dadadj -!----------------------------------------------------------------------- -! -! Purpose: -! GFDL style dry adiabatic adjustment -! -! Method: -! if stratification is unstable, adjustment to the dry adiabatic lapse -! rate is forced subject to the condition that enthalpy is conserved. -! -! Author: J.Hack -! -!----------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 - -implicit none -private -save - -public :: & - dadadj_initial, & - dadadj_calc - -integer :: nlvdry ! number of layers from top of model to apply the adjustment -integer :: niter ! number of iterations for convergence - -!=============================================================================== -contains -!=============================================================================== - -subroutine dadadj_initial(nlvdry_in, niter_in) - - integer, intent(in) :: nlvdry_in - integer, intent(in) :: niter_in - - nlvdry = nlvdry_in - niter = niter_in - -end subroutine dadadj_initial - -!=============================================================================== - -subroutine dadadj_calc( & - ncol, pmid, pint, pdel, cappav, t, & - q, dadpdf, icol_err) - - ! Arguments - - integer, intent(in) :: ncol ! number of atmospheric columns - - real(r8), intent(in) :: pmid(:,:) ! pressure at model levels - real(r8), intent(in) :: pint(:,:) ! pressure at model interfaces - real(r8), intent(in) :: pdel(:,:) ! vertical delta-p - real(r8), intent(in) :: cappav(:,:) ! variable Kappa - - real(r8), intent(inout) :: t(:,:) ! temperature (K) - real(r8), intent(inout) :: q(:,:) ! specific humidity - - real(r8), intent(out) :: dadpdf(:,:) ! PDF of where adjustments happened - - integer, intent(out) :: icol_err ! index of column in which error occurred - - !---------------------------Local workspace----------------------------- - - integer :: i,k ! longitude, level indices - integer :: jiter ! iteration index - - real(r8), allocatable :: c1dad(:) ! intermediate constant - real(r8), allocatable :: c2dad(:) ! intermediate constant - real(r8), allocatable :: c3dad(:) ! intermediate constant - real(r8), allocatable :: c4dad(:) ! intermediate constant - real(r8) :: gammad ! dry adiabatic lapse rate (deg/Pa) - real(r8) :: zeps ! convergence criterion (deg/Pa) - real(r8) :: rdenom ! reciprocal of denominator of expression - real(r8) :: dtdp ! delta-t/delta-p - real(r8) :: zepsdp ! zeps*delta-p - real(r8) :: zgamma ! intermediate constant - real(r8) :: qave ! mean q between levels - real(r8) :: cappa ! Kappa at level intefaces - - logical :: ilconv ! .TRUE. ==> convergence was attained - logical :: dodad(ncol) ! .TRUE. ==> do dry adjustment - - !----------------------------------------------------------------------- - - icol_err = 0 - zeps = 2.0e-5_r8 ! set convergence criteria - - allocate(c1dad(nlvdry), c2dad(nlvdry), c3dad(nlvdry), c4dad(nlvdry)) - - ! Find gridpoints with unstable stratification - - do i = 1, ncol - cappa = 0.5_r8*(cappav(i,2) + cappav(i,1)) - gammad = cappa*0.5_r8*(t(i,2) + t(i,1))/pint(i,2) - dtdp = (t(i,2) - t(i,1))/(pmid(i,2) - pmid(i,1)) - dodad(i) = (dtdp + zeps) .gt. gammad - end do - - dadpdf(:ncol,:) = 0._r8 - do k= 2, nlvdry - do i = 1, ncol - cappa = 0.5_r8*(cappav(i,k+1) + cappav(i,k)) - gammad = cappa*0.5_r8*(t(i,k+1) + t(i,k))/pint(i,k+1) - dtdp = (t(i,k+1) - t(i,k))/(pmid(i,k+1) - pmid(i,k)) - dodad(i) = dodad(i) .or. (dtdp + zeps).gt.gammad - if ((dtdp + zeps).gt.gammad) then - dadpdf(i,k) = 1._r8 - end if - end do - end do - - ! Make a dry adiabatic adjustment - ! Note: nlvdry ****MUST**** be < pver - - COL: do i = 1, ncol - - if (dodad(i)) then - - zeps = 2.0e-5_r8 - - do k = 1, nlvdry - c1dad(k) = cappa*0.5_r8*(pmid(i,k+1)-pmid(i,k))/pint(i,k+1) - c2dad(k) = (1._r8 - c1dad(k))/(1._r8 + c1dad(k)) - rdenom = 1._r8/(pdel(i,k)*c2dad(k) + pdel(i,k+1)) - c3dad(k) = rdenom*pdel(i,k) - c4dad(k) = rdenom*pdel(i,k+1) - end do - -50 continue - - do jiter = 1, niter - ilconv = .true. - - do k = 1, nlvdry - zepsdp = zeps*(pmid(i,k+1) - pmid(i,k)) - zgamma = c1dad(k)*(t(i,k) + t(i,k+1)) - - if ((t(i,k+1)-t(i,k)) >= (zgamma+zepsdp)) then - ilconv = .false. - t(i,k+1) = t(i,k)*c3dad(k) + t(i,k+1)*c4dad(k) - t(i,k) = c2dad(k)*t(i,k+1) - qave = (pdel(i,k+1)*q(i,k+1) + pdel(i,k)*q(i,k))/(pdel(i,k+1)+ pdel(i,k)) - q(i,k+1) = qave - q(i,k) = qave - end if - - end do - - if (ilconv) cycle COL ! convergence => next longitude - end do - - ! Double convergence criterion if no convergence in niter iterations - - zeps = zeps + zeps - if (zeps > 1.e-4_r8) then - icol_err = i - return ! error return - else - go to 50 - end if - - end if - - end do COL - - deallocate(c1dad, c2dad, c3dad, c4dad) - -end subroutine dadadj_calc - -!=============================================================================== - -end module dadadj diff --git a/src/physics/cam/dadadj_cam.F90 b/src/physics/cam/dadadj_cam.F90 index 0717865ca8..d12c307ac9 100644 --- a/src/physics/cam/dadadj_cam.F90 +++ b/src/physics/cam/dadadj_cam.F90 @@ -2,7 +2,7 @@ module dadadj_cam ! CAM interfaces for the dry adiabatic adjustment parameterization -use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs +use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs, cm=>shr_kind_cm use ppgrid, only: pcols, pver, pverp use constituents, only: pcnst use air_composition, only: cappav, cpairv @@ -17,7 +17,7 @@ module dadadj_cam use namelist_utils, only: find_group_name use units, only: getunit, freeunit -use dadadj, only: dadadj_initial, dadadj_calc +use dadadj, only: dadadj_init, dadadj_run implicit none private @@ -25,7 +25,7 @@ module dadadj_cam public :: & dadadj_readnl, & - dadadj_init, & + dadadj_cam_init, & dadadj_tend ! Namelist variables @@ -42,8 +42,10 @@ subroutine dadadj_readnl(filein) namelist /dadadj_nl/ dadadj_nlvdry, dadadj_niter - integer :: unitn, ierr - character(len=*), parameter :: sub='dadadj_readnl' + integer :: unitn, ierr + integer :: errflg ! CCPP physics scheme error flag + character(len=512) :: errmsg ! CCPP physics scheme error message + character(len=*), parameter :: sub='dadadj_readnl' !------------------------------------------------------------------ ! Read namelist @@ -67,13 +69,16 @@ subroutine dadadj_readnl(filein) call mpibcast(dadadj_niter, 1, mpi_integer, masterprocid, mpicom) #endif - call dadadj_initial(dadadj_nlvdry, dadadj_niter) + call dadadj_init(dadadj_nlvdry, dadadj_niter, pver, errmsg, errflg) + if (errflg /=0) then + call endrun('dadadj_readnl: Error returned from dadadj_init: '//trim(errmsg)) + end if if (masterproc .and. .not. use_simple_phys) then write(iulog,*)'Dry adiabatic adjustment applied to top N layers; N=', & - dadadj_nlvdry + dadadj_nlvdry write(iulog,*)'Dry adiabatic adjustment number of iterations for convergence =', & - dadadj_niter + dadadj_niter end if end subroutine dadadj_readnl @@ -81,12 +86,12 @@ end subroutine dadadj_readnl !=============================================================================== -subroutine dadadj_init() +subroutine dadadj_cam_init() use cam_history, only: addfld call addfld('DADADJ_PD', (/ 'lev' /), 'A', 'probability', 'dry adiabatic adjustment probability') -end subroutine dadadj_init +end subroutine dadadj_cam_init !=============================================================================== @@ -98,39 +103,46 @@ subroutine dadadj_tend(dt, state, ptend) type(physics_state), intent(in) :: state ! Physics state variables type(physics_ptend), intent(out) :: ptend ! parameterization tendencies - logical :: lq(pcnst) - real(r8) :: dadpdf(pcols, pver) - integer :: ncol, lchnk, icol_err - character(len=128) :: errstring ! Error string - - ncol = state%ncol - lchnk = state%lchnk - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend, state%psetcols, 'dadadj', ls=.true., lq=lq) - - ! use the ptend components for temporary storate and copy state info for input to - ! dadadj_calc which directly updates the temperature and moisture input arrays. - - ptend%s(:ncol,:pver) = state%t(:ncol,:pver) - ptend%q(:ncol,:pver,1) = state%q(:ncol,:pver,1) - - call dadadj_calc( & - ncol, state%pmid, state%pint, state%pdel, cappav(:,:,lchnk), ptend%s, & - ptend%q(:,:,1), dadpdf, icol_err) - - call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) - - if (icol_err > 0) then - ! error exit - write(errstring, *) & - 'dadadj_calc: No convergence in column at lat,lon:', & - state%lat(icol_err)*180._r8/pi, state%lon(icol_err)*180._r8/pi - call handle_errmsg(errstring, subname="dadadj_tend") - end if - - ptend%s(:ncol,:) = (ptend%s(:ncol,:) - state%t(:ncol,:) )/dt * cpairv(:ncol,:,lchnk) - ptend%q(:ncol,:,1) = (ptend%q(:ncol,:,1) - state%q(:ncol,:,1))/dt + character(len=512) :: errstring ! Error string + character(len=512) :: errmsg ! CCPP physics scheme error message + character(len=64) :: scheme_name! CCPP physics scheme name (not used in CAM) + integer :: icol_err + integer :: lchnk + integer :: ncol + integer :: errflg ! CCPP physics scheme error flag + logical :: lq(pcnst) + real(r8) :: dadpdf(pcols, pver) + + !------------------------------------------------------------------ + ncol = state%ncol + lchnk = state%lchnk + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend, state%psetcols, 'dadadj', ls=.true., lq=lq) + + !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + dadpdf = 0._r8 + ptend%s = 0._r8 + ptend%q = 0._r8 + !REMOVECAM_END + + ! dadadj_run returns t tend, we are passing the ptend%s array to receive the t tendency and will convert it to s + ! before it is returned to CAM.. + call dadadj_run( & + ncol, dt, state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), state%t(:ncol,:), state%q(:ncol,:,1), cappav(:ncol,:,lchnk), & + ptend%s(:ncol,:), ptend%q(:ncol,:,1), dadpdf(:ncol,:), scheme_name, errmsg, errflg) + + if (errflg /= 0) then + ! error exit + write(errstring, *) errmsg,' at lat,lon:', & + state%lat(errflg)*180._r8/pi, state%lon(errflg)*180._r8/pi + call endrun('dadadj_tend: Error returned from dadadj_run: '//trim(errstring)) + end if + + call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) + + ! convert the t tendency to an s tendency for cam + ptend%s(:ncol,:) = ptend%s(:ncol,:) * cpairv(:ncol,:,lchnk) end subroutine dadadj_tend diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index cb7322254f..883b774fd1 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -777,7 +777,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use sslt_rebin, only: sslt_rebin_init use tropopause, only: tropopause_init use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_init + use dadadj_cam, only: dadadj_cam_init use cam_abortutils, only: endrun use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init @@ -952,7 +952,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) #endif call sslt_rebin_init() call tropopause_init() - call dadadj_init() + call dadadj_cam_init() prec_dp_idx = pbuf_get_index('PREC_DP') snow_dp_idx = pbuf_get_index('SNOW_DP') diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index aef997716f..45d195de2e 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -761,7 +761,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use clubb_intr, only: clubb_ini_cam use tropopause, only: tropopause_init use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_init + use dadadj_cam, only: dadadj_cam_init use cam_abortutils, only: endrun use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init @@ -920,7 +920,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call metdata_phys_init() #endif call tropopause_init() - call dadadj_init() + call dadadj_cam_init() prec_dp_idx = pbuf_get_index('PREC_DP') snow_dp_idx = pbuf_get_index('SNOW_DP') From 9eb07a19ddfabf2c5fee426aeb02917b7c38a8c5 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Mon, 6 May 2024 09:51:51 -0600 Subject: [PATCH 24/75] Update Externals_CAM to point to my new atmos_phys branch - will need to redirect this to the tagged version --- Externals_CAM.cfg | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index a1c76e7db5..9ea695165f 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -50,9 +50,9 @@ tag = ALI_ARMS_v1.0.1 required = True [atmos_phys] -tag = atmos_phys0_02_006 +branch = dadadj protocol = git -repo_url = https://github.com/ESCOMP/atmospheric_physics +repo_url = https://github.com/jtruesdal/atmospheric_physics required = True local_path = src/atmos_phys From 6f988cdff1fe6c5890cc3432893e8fc5d49a1b4c Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Wed, 15 May 2024 16:43:22 -0600 Subject: [PATCH 25/75] PR updates --- src/dynamics/se/dycore/prim_advance_mod.F90 | 2 +- src/dynamics/se/dycore/vertremap_mod.F90 | 25 +++-- src/dynamics/se/dycore/viscosity_mod.F90 | 104 ++++++++++---------- src/dynamics/se/dyn_comp.F90 | 4 +- src/dynamics/se/dyn_grid.F90 | 15 +-- src/dynamics/se/gravity_waves_sources.F90 | 24 ++--- src/dynamics/se/stepon.F90 | 2 +- src/utils/hycoef.F90 | 11 +++ 8 files changed, 91 insertions(+), 96 deletions(-) diff --git a/src/dynamics/se/dycore/prim_advance_mod.F90 b/src/dynamics/se/dycore/prim_advance_mod.F90 index ed7a627ec4..8a292f35c0 100644 --- a/src/dynamics/se/dycore/prim_advance_mod.F90 +++ b/src/dynamics/se/dycore/prim_advance_mod.F90 @@ -505,7 +505,7 @@ subroutine advance_hypervis_dp(edge3,elem,fvm,hybrid,deriv,nt,qn0,nets,nete,dt2, call tot_energy_dyn(elem,fvm,nets,nete,nt,qn0,'dBH') rhypervis_subcycle=1.0_r8/real(hypervis_subcycle,kind=r8) - call biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend,hvcoord) + call biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend) do ie=nets,nete ! compute mean flux diff --git a/src/dynamics/se/dycore/vertremap_mod.F90 b/src/dynamics/se/dycore/vertremap_mod.F90 index 3b57fd891e..59fc6afddd 100644 --- a/src/dynamics/se/dycore/vertremap_mod.F90 +++ b/src/dynamics/se/dycore/vertremap_mod.F90 @@ -17,7 +17,6 @@ module vertremap_mod use shr_kind_mod, only: r8=>shr_kind_r8 use dimensions_mod, only: np,nlev,qsize,nlevp,npsq,nc - use hybvcoord_mod, only: hvcoord_t use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct use perf_mod, only: t_startf, t_stopf ! _EXTERNAL @@ -25,7 +24,7 @@ module vertremap_mod use cam_abortutils, only: endrun implicit none - + public remap1 ! remap any field, splines, monotone public remap1_nofilter ! remap any field, splines, no filter ! todo: tweak interface to match remap1 above, rename remap1_ppm: @@ -65,19 +64,19 @@ subroutine remap1(Qdp,nx,qstart,qstop,qsize,dp1,dp2,ptop,identifier,Qdp_mass,kor if (any(kord(:) >= 0)) then if (.not.qdp_mass) then do itrac=1,qsize - if (kord(itrac) >= 0) then + if (kord(itrac) >= 0) then Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)*dp1(:,:,:) end if end do - end if + end if call remap_Q_ppm(qdp,nx,qstart,qstop,qsize,dp1,dp2,kord) if (.not.qdp_mass) then do itrac=1,qsize - if (kord(itrac) >= 0) then + if (kord(itrac) >= 0) then Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)/dp2(:,:,:) end if end do - end if + end if endif if (any(kord(:)<0)) then ! @@ -89,20 +88,20 @@ subroutine remap1(Qdp,nx,qstart,qstop,qsize,dp1,dp2,ptop,identifier,Qdp_mass,kor kord_local = abs(kord) logp = .false. else - kord_local = abs(kord/10) + kord_local = abs(kord/10) if (identifier==1) then logp = .true. else - logp = .false. + logp = .false. end if end if ! ! modified FV3 vertical remapping - ! + ! if (qdp_mass) then inv_dp = 1.0_r8/dp1 do itrac=1,qsize - if (kord(itrac)<0) then + if (kord(itrac)<0) then Qdp(:,:,:,itrac) = Qdp(:,:,:,itrac)*inv_dp(:,:,:) end if end do @@ -124,7 +123,7 @@ subroutine remap1(Qdp,nx,qstart,qstop,qsize,dp1,dp2,ptop,identifier,Qdp_mass,kor pe2(i,k) = log(pe2(i,k)) end do end do - + do itrac=1,qsize if (kord(itrac)<0) then call map1_ppm( nlev, pe1(:,:), Qdp(:,:,:,itrac), gz, & @@ -457,7 +456,7 @@ subroutine binary_search(pio, pivot, k) real(kind=r8), intent(in) :: pio(nlev+2), pivot integer, intent(inout) :: k integer :: lo, hi, mid - + if (pio(k) > pivot) then lo = 1 hi = k @@ -597,7 +596,7 @@ subroutine linextrap(dx1,dx2,dx3,dx4,y1,y2,y3,y4,lo,hi) y4 = (1.0_r8-a)*y1 + a*y2 y3 = max(lo, min(hi, y3)) y4 = max(lo, min(hi, y4)) - end subroutine linextrap + end subroutine linextrap end module vertremap_mod !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/dynamics/se/dycore/viscosity_mod.F90 b/src/dynamics/se/dycore/viscosity_mod.F90 index 04b0a1a91d..51bf63a3da 100644 --- a/src/dynamics/se/dycore/viscosity_mod.F90 +++ b/src/dynamics/se/dycore/viscosity_mod.F90 @@ -1,9 +1,9 @@ module viscosity_mod ! ! This module should be renamed "global_deriv_mod.F90" -! -! It is a collection of derivative operators that must be applied to the field -! over the sphere (as opposed to derivative operators that can be applied element +! +! It is a collection of derivative operators that must be applied to the field +! over the sphere (as opposed to derivative operators that can be applied element ! by element) ! ! @@ -50,10 +50,9 @@ module viscosity_mod CONTAINS -subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend,hvcoord) +subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid,nt,nets,nete,kbeg,kend) use derivative_mod, only : subcell_Laplace_fluxes use dimensions_mod, only : use_cslam, nu_div_lev,nu_lev - use hybvcoord_mod, only : hvcoord_t !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! compute weak biharmonic operator ! input: h,v (stored in elem()%, in lat-lon coordinates @@ -69,25 +68,24 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, real (kind=r8), dimension(np,np,nlev,nets:nete) :: ttens,dptens type (EdgeBuffer_t) , intent(inout) :: edge3 type (derivative_t) , intent(in) :: deriv - type (hvcoord_t) , intent(in) :: hvcoord ! local integer :: i,j,k,kptr,ie,kblk ! real (kind=r8), dimension(:,:), pointer :: rspheremv real (kind=r8), dimension(np,np) :: tmp real (kind=r8), dimension(np,np) :: tmp2 real (kind=r8), dimension(np,np,2) :: v - + real (kind=r8), dimension(np,np,nlev) :: lap_p_wk real (kind=r8), dimension(np,np,nlevp) :: T_i real (kind=r8) :: nu_ratio1, nu_ratio2, dp_thresh logical var_coef1 - + kblk = kend - kbeg + 1 - + if (use_cslam) dpflux = 0 - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. @@ -123,10 +121,10 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, kptr = kbeg - 1 call edgeVpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie) - kptr = kbeg - 1 + nlev + kptr = kbeg - 1 + nlev call edgeVpack(edge3,vtens(:,:,1,kbeg:kend,ie),kblk,kptr,ie) - kptr = kbeg - 1 + 2*nlev + kptr = kbeg - 1 + 2*nlev call edgeVpack(edge3,vtens(:,:,2,kbeg:kend,ie),kblk,kptr,ie) kptr = kbeg - 1 + 3*nlev @@ -137,7 +135,7 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, do ie=nets,nete !CLEAN rspheremv => elem(ie)%rspheremp(:,:) - + kptr = kbeg - 1 call edgeVunpack(edge3,ttens(:,:,kbeg:kend,ie),kblk,kptr,ie) @@ -157,7 +155,7 @@ subroutine biharmonic_wk_dp3d(elem,dptens,dpflux,ttens,vtens,deriv,edge3,hybrid, call subcell_Laplace_fluxes(tmp, deriv, elem(ie), np, nc,dpflux(:,:,:,k,ie)) enddo endif - + ! apply inverse mass matrix, then apply laplace again !$omp parallel do num_threads(vert_num_threads) private(k,v,tmp,tmp2) do k=kbeg,kend @@ -198,37 +196,37 @@ subroutine biharmonic_wk_omega(elem,ptens,deriv,edge3,hybrid,nets,nete,kbeg,kend real (kind=r8), dimension(np,np,2) :: v real (kind=r8) :: nu_ratio1, nu_ratio2 logical var_coef1 - + kblk = kend - kbeg + 1 - - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. - + nu_ratio1=1 nu_ratio2=1 - + do ie=nets,nete - + !$omp parallel do num_threads(vert_num_threads) private(k,tmp) do k=kbeg,kend - tmp=elem(ie)%derived%omega(:,:,k) + tmp=elem(ie)%derived%omega(:,:,k) call laplace_sphere_wk(tmp,deriv,elem(ie),ptens(:,:,k,ie),var_coef=var_coef1) enddo - + kptr = kbeg - 1 call edgeVpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie) enddo - + call bndry_exchange(hybrid,edge3,location='biharmonic_wk_omega') - + do ie=nets,nete rspheremv => elem(ie)%rspheremp(:,:) - + kptr = kbeg - 1 call edgeVunpack(edge3,ptens(:,:,kbeg:kend,ie),kblk,kptr,ie) - + ! apply inverse mass matrix, then apply laplace again !$omp parallel do num_threads(vert_num_threads) private(k,tmp) do k=kbeg,kend @@ -256,14 +254,14 @@ subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete) ! local integer :: k,kptr,i,j,ie,ic,q -integer :: kbeg,kend,qbeg,qend +integer :: kbeg,kend,qbeg,qend real (kind=r8), dimension(np,np) :: lap_p logical var_coef1 integer :: kblk,qblk ! The per thead size of the vertical and tracers call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) - !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) + !if tensor hyperviscosity with tensor V is used, then biharmonic operator is (\grad\cdot V\grad) (\grad \cdot \grad) !so tensor is only used on second call to laplace_sphere_wk var_coef1 = .true. if(hypervis_scaling > 0) var_coef1 = .false. @@ -273,7 +271,7 @@ subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete) qblk = qend - qbeg + 1 ! calculate size of the block of tracers do ie=nets,nete - do q=qbeg,qend + do q=qbeg,qend do k=kbeg,kend lap_p(:,:)=qtens(:,:,k,q,ie) call laplace_sphere_wk(lap_p,deriv,elem(ie),qtens(:,:,k,q,ie),var_coef=var_coef1) @@ -285,11 +283,11 @@ subroutine biharmonic_wk_scalar(elem,qtens,deriv,edgeq,hybrid,nets,nete) call bndry_exchange(hybrid,edgeq,location='biharmonic_wk_scalar') - + do ie=nets,nete ! apply inverse mass matrix, then apply laplace again - do q=qbeg,qend + do q=qbeg,qend kptr = nlev*(q-1) + kbeg - 1 call edgeVunpack(edgeq, qtens(:,:,kbeg:kend,q,ie),kblk,kptr,ie) do k=kbeg,kend @@ -305,7 +303,7 @@ end subroutine biharmonic_wk_scalar subroutine make_C0(zeta,elem,hybrid,nets,nete) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! apply DSS (aka assembly procedure) to zeta. +! apply DSS (aka assembly procedure) to zeta. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type (hybrid_t) , intent(in) :: hybrid @@ -341,7 +339,7 @@ subroutine make_C0(zeta,elem,hybrid,nets,nete) enddo enddo -call FreeEdgeBuffer(edge1) +call FreeEdgeBuffer(edge1) end subroutine @@ -409,7 +407,7 @@ subroutine make_C0_vector(v,elem,hybrid,nets,nete) enddo enddo -call FreeEdgeBuffer(edge2) +call FreeEdgeBuffer(edge2) #endif end subroutine @@ -420,11 +418,11 @@ subroutine make_C0_vector(v,elem,hybrid,nets,nete) subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in contra-variant coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -459,11 +457,11 @@ subroutine compute_zeta_C0_contra(zeta,elem,hybrid,nets,nete,nt) subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in contra-variant coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -496,11 +494,11 @@ subroutine compute_div_C0_contra(zeta,elem,hybrid,nets,nete,nt) subroutine compute_zeta_C0_par(zeta,elem,par,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! type (parallel_t) :: par @@ -523,11 +521,11 @@ subroutine compute_zeta_C0_par(zeta,elem,par,nt) subroutine compute_div_C0_par(zeta,elem,par,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -552,11 +550,11 @@ subroutine compute_div_C0_par(zeta,elem,par,nt) subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 vorticity. That is, solve: +! compute C0 vorticity. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -587,11 +585,11 @@ subroutine compute_zeta_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! compute C0 divergence. That is, solve: +! compute C0 divergence. That is, solve: ! < PHI, zeta > = ! ! input: v (stored in elem()%, in lat-lon coordinates) -! output: zeta(:,:,:,:) +! output: zeta(:,:,:,:) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -627,22 +625,22 @@ subroutine compute_div_C0_hybrid(zeta,elem,hybrid,nets,nete,nt) subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) - + type (hybrid_t) , intent(in) :: hybrid type (EdgeBuffer_t) , intent(inout) :: edgeMinMax integer :: nets,nete real (kind=r8) :: min_neigh(nlev,qsize,nets:nete) real (kind=r8) :: max_neigh(nlev,qsize,nets:nete) integer :: kblk, qblk - ! local + ! local integer:: ie, q, k, kptr integer:: kbeg, kend, qbeg, qend call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) - + kblk = kend - kbeg + 1 ! calculate size of the block of vertical levels qblk = qend - qbeg + 1 ! calculate size of the block of tracers - + do ie=nets,nete do q = qbeg, qend kptr = nlev*(q - 1) + kbeg - 1 @@ -651,7 +649,7 @@ subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) call edgeSpack(edgeMinMax,max_neigh(kbeg:kend,q,ie),kblk,kptr,ie) enddo enddo - + call bndry_exchange(hybrid,edgeMinMax,location='neighbor_minmax') do ie=nets,nete @@ -667,7 +665,7 @@ subroutine neighbor_minmax(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) enddo end subroutine neighbor_minmax - + subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh) @@ -679,7 +677,7 @@ subroutine neighbor_minmax_start(hybrid,edgeMinMax,nets,nete,min_neigh,max_neigh integer :: kblk, qblk integer :: kbeg, kend, qbeg, qend - ! local + ! local integer :: ie,q, k,kptr call get_loop_ranges(hybrid,kbeg=kbeg,kend=kend,qbeg=qbeg,qend=qend) diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index 59be97d1e4..907a4cd6d0 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -11,7 +11,7 @@ module dyn_comp use cam_control_mod, only: initial_run use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim use phys_control, only: use_gw_front, use_gw_front_igw -use dyn_grid, only: ini_grid_name, timelevel, hvcoord, edgebuf, & +use dyn_grid, only: ini_grid_name, timelevel, edgebuf, & ini_grid_hdim_name use cam_grid_support, only: cam_grid_id, cam_grid_get_gcid, & @@ -48,6 +48,7 @@ module dyn_comp use bndry_mod, only: bndry_exchange use se_single_column_mod, only: scm_setinitial use scamMod, only: single_column, readiopdata, use_iop, setiopupdate_init +use hycoef, only: hyai, hybi, ps0, hvcoord implicit none private @@ -1173,7 +1174,6 @@ end subroutine dyn_final subroutine read_inidat(dyn_in) use air_composition, only: thermodynamic_active_species_num, dry_air_species_num use shr_sys_mod, only: shr_sys_flush - use hycoef, only: hyai, hybi, ps0 use const_init, only: cnst_init_default use element_mod, only: timelevels diff --git a/src/dynamics/se/dyn_grid.F90 b/src/dynamics/se/dyn_grid.F90 index e6b8318d0f..23623ac9e6 100644 --- a/src/dynamics/se/dyn_grid.F90 +++ b/src/dynamics/se/dyn_grid.F90 @@ -44,7 +44,6 @@ module dyn_grid use dimensions_mod, only: ne, np, npsq, fv_nphys, nlev, use_cslam use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct -use hybvcoord_mod, only: hvcoord_t use prim_init, only: prim_init1 use edge_mod, only: initEdgeBuffer use edgetype_mod, only: EdgeBuffer_t @@ -68,7 +67,6 @@ module dyn_grid integer, parameter :: ptimelevels = 2 type (TimeLevel_t) :: TimeLevel ! main time level struct (used by tracers) -type (hvcoord_t) :: hvcoord type(element_t), pointer :: elem(:) => null() ! local GLL elements for this task type(fvm_struct), pointer :: fvm(:) => null() ! local FVM elements for this task @@ -77,7 +75,6 @@ module dyn_grid public :: ini_grid_hdim_name public :: ptimelevels public :: TimeLevel -public :: hvcoord public :: elem public :: fvm public :: edgebuf @@ -122,8 +119,7 @@ subroutine dyn_grid_init() ! Initialize SE grid, and decomposition. - use hycoef, only: hycoef_init, hypi, hypm, nprlev, & - hyam, hybm, hyai, hybi, ps0 + use hycoef, only: hycoef_init, hypi, hypm, nprlev use ref_pres, only: ref_pres_init use spmd_utils, only: MPI_MAX, MPI_INTEGER, mpicom use time_manager, only: get_nstep, get_step_size @@ -163,15 +159,6 @@ subroutine dyn_grid_init() ! Initialize hybrid coordinate arrays call hycoef_init(fh_ini, psdry=.true.) - hvcoord%hyam = hyam - hvcoord%hyai = hyai - hvcoord%hybm = hybm - hvcoord%hybi = hybi - hvcoord%ps0 = ps0 - do k = 1, nlev - hvcoord%hybd(k) = hvcoord%hybi(k+1) - hvcoord%hybi(k) - end do - ! Initialize reference pressures call ref_pres_init(hypi, hypm, nprlev) diff --git a/src/dynamics/se/gravity_waves_sources.F90 b/src/dynamics/se/gravity_waves_sources.F90 index 9adffc001b..8a1dbecd22 100644 --- a/src/dynamics/se/gravity_waves_sources.F90 +++ b/src/dynamics/se/gravity_waves_sources.F90 @@ -74,7 +74,7 @@ subroutine gws_src_fnct(elem, tl, tlq, frontgf, frontga,nphys) call get_loop_ranges(hybrid,ibeg=nets,iend=nete) allocate(frontgf_thr(nphys,nphys,nlev,nets:nete)) - allocate(frontga_thr(nphys,nphys,nlev,nets:nete)) + allocate(frontga_thr(nphys,nphys,nlev,nets:nete)) call compute_frontogenesis(frontgf_thr,frontga_thr,tl,tlq,elem,deriv,hybrid,nets,nete,nphys) if (fv_nphys>0) then do ie=nets,nete @@ -111,14 +111,14 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use physconst, only: cappa use air_composition,only: dry_air_species_num, thermodynamic_active_species_num - use air_composition,only: thermodynamic_active_species_idx_dycore + use air_composition,only: thermodynamic_active_species_idx_dycore use derivative_mod, only: gradient_sphere, ugradv_sphere use edge_mod, only: edgevpack, edgevunpack use bndry_mod, only: bndry_exchange - use dyn_grid, only: hvcoord + use hycoef, only: hvcoord use dimensions_mod, only: fv_nphys,ntrac use fvm_mapping, only: dyn2phys_vector,dyn2phys - + type(hybrid_t), intent(in) :: hybrid type(element_t), intent(inout), target :: elem(:) type(derivative_t), intent(in) :: ederiv @@ -141,7 +141,7 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, do ie=nets,nete ! pressure at model top - pint(:,:) = hvcoord%hyai(1) + pint(:,:) = hvcoord%hyai(1) do k=1,nlev ! moist pressure at mid points sum_water(:,:) = 1.0_r8 @@ -157,16 +157,16 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, pint(:,:) = pint(:,:)+elem(ie)%state%dp3d(:,:,k,tl) ! theta(:,:) = elem(ie)%state%T(:,:,k,tl)*(psurf_ref / p(:,:))**cappa - ! gradth(:,:,:,k,ie) = gradient_sphere(theta,ederiv,elem(ie)%Dinv) - call gradient_sphere(theta,ederiv,elem(ie)%Dinv,gradth(:,:,:,k,ie)) + ! gradth(:,:,:,k,ie) = gradient_sphere(theta,ederiv,elem(ie)%Dinv) + call gradient_sphere(theta,ederiv,elem(ie)%Dinv,gradth(:,:,:,k,ie)) ! compute C = (grad(theta) dot grad ) u - C(:,:,:) = ugradv_sphere(gradth(:,:,:,k,ie), elem(ie)%state%v(:,:,:,k,tl),ederiv,elem(ie)) + C(:,:,:) = ugradv_sphere(gradth(:,:,:,k,ie), elem(ie)%state%v(:,:,:,k,tl),ederiv,elem(ie)) ! gradth dot C - frontgf_gll(:,:,k,ie) = -( C(:,:,1)*gradth(:,:,1,k,ie) + C(:,:,2)*gradth(:,:,2,k,ie) ) + frontgf_gll(:,:,k,ie) = -( C(:,:,1)*gradth(:,:,1,k,ie) + C(:,:,2)*gradth(:,:,2,k,ie) ) ! apply mass matrix gradth(:,:,1,k,ie)=gradth(:,:,1,k,ie)*elem(ie)%spheremp(:,:) gradth(:,:,2,k,ie)=gradth(:,:,2,k,ie)*elem(ie)%spheremp(:,:) - frontgf_gll(:,:,k,ie)=frontgf_gll(:,:,k,ie)*elem(ie)%spheremp(:,:) + frontgf_gll(:,:,k,ie)=frontgf_gll(:,:,k,ie)*elem(ie)%spheremp(:,:) enddo ! pack call edgeVpack(edge3, frontgf_gll(:,:,:,ie),nlev,0,ie) @@ -180,7 +180,7 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, do k=1,nlev gradth(:,:,1,k,ie)=gradth(:,:,1,k,ie)*elem(ie)%rspheremp(:,:) gradth(:,:,2,k,ie)=gradth(:,:,2,k,ie)*elem(ie)%rspheremp(:,:) - frontgf_gll(:,:,k,ie)=frontgf_gll(:,:,k,ie)*elem(ie)%rspheremp(:,:) + frontgf_gll(:,:,k,ie)=frontgf_gll(:,:,k,ie)*elem(ie)%rspheremp(:,:) end do if (fv_nphys>0) then uv_tmp(:,:,:) = dyn2phys_vector(gradth(:,:,:,:,ie),elem(ie)) @@ -201,7 +201,7 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, area_inv = 1.0_r8/area_inv do k=1,nlev frontgf(:,:,k,ie) = dyn2phys(frontgf_gll(:,:,k,ie),elem(ie)%metdet,area_inv) - end do + end do else do k=1,nlev frontgf(:,:,k,ie)=frontgf_gll(:,:,k,ie) diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index cbd30ee0c3..98482ff1c8 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -19,7 +19,7 @@ module stepon use scamMod, only: use_iop, doiopupdate, single_column, & setiopupdate, readiopdata use se_single_column_mod, only: scm_setfield, iop_broadcast -use dyn_grid, only: hvcoord +use hycoef, only: hvcoord use time_manager, only: get_step_size, is_first_restart_step use cam_history, only: outfld, write_camiop, addfld, add_default, horiz_only use cam_history, only: write_inithist, hist_fld_active, fieldname_len diff --git a/src/utils/hycoef.F90 b/src/utils/hycoef.F90 index 2abfbb2ec7..378f6896c3 100644 --- a/src/utils/hycoef.F90 +++ b/src/utils/hycoef.F90 @@ -10,6 +10,7 @@ module hycoef pio_double, pio_def_dim, pio_def_var, & pio_put_var, pio_get_var, & pio_seterrorhandling, PIO_BCAST_ERROR, PIO_NOERR +use hybvcoord_mod, only: hvcoord_t implicit none private @@ -48,6 +49,8 @@ module hycoef public hycoef_init +type (hvcoord_t),public :: hvcoord + type(var_desc_t) :: hyam_desc, hyai_desc, hybm_desc, hybi_desc, p0_desc public init_restart_hycoef, write_restart_hycoef @@ -241,6 +244,14 @@ subroutine hycoef_init(file, psdry) formula_terms=formula_terms) end if + ! Initialize the hvcoord coordinate + hvcoord%hyam = hyam + hvcoord%hyai = hyai + hvcoord%hybm = hybm + hvcoord%hybi = hybi + hvcoord%hybd = hybd + hvcoord%ps0 = ps0 + if (masterproc) then write(iulog,'(a)')' Layer Locations (*1000) ' do k=1,plev From bb48a6dd29de8db242424ea892450ccb50158df6 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Tue, 14 May 2024 10:45:10 -0600 Subject: [PATCH 26/75] Update externals to match cesm2_3_alpha17f --- Externals.cfg | 25 +++++++++---------------- cime_config/testdefs/testlist_cam.xml | 2 +- 2 files changed, 10 insertions(+), 17 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index ffe2c4b012..f967878539 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,5 +1,5 @@ [ccs_config] -tag = ccs_config_cesm0.0.85 +tag = ccs_config_cesm0.0.106 protocol = git repo_url = https://github.com/ESMCI/ccs_config_cesm local_path = ccs_config @@ -13,7 +13,7 @@ local_path = components/cice5 required = True [cice6] -tag = cesm_cice6_4_1_10 +tag = cesm_cice6_5_0_7 protocol = git repo_url = https://github.com/ESCOMP/CESM_CICE local_path = components/cice @@ -21,14 +21,14 @@ externals = Externals.cfg required = True [cmeps] -tag = cmeps0.14.59 +tag = cmeps0.14.60 protocol = git repo_url = https://github.com/ESCOMP/CMEPS.git local_path = components/cmeps required = True [cdeps] -tag = cdeps1.0.31 +tag = cdeps1.0.33 protocol = git repo_url = https://github.com/ESCOMP/CDEPS.git local_path = components/cdeps @@ -36,7 +36,7 @@ externals = Externals_CDEPS.cfg required = True [cpl7] -tag = cpl77.0.7 +tag = cpl77.0.8 protocol = git repo_url = https://github.com/ESCOMP/CESM_CPL7andDataComps local_path = components/cpl7 @@ -49,13 +49,6 @@ repo_url = https://github.com/ESCOMP/CESM_share local_path = share required = True -[mct] -tag = MCT_2.11.0 -protocol = git -repo_url = https://github.com/MCSclimate/MCT -local_path = libraries/mct -required = True - [parallelio] tag = pio2_6_2 protocol = git @@ -71,7 +64,7 @@ local_path = cime required = True [cism] -tag = cismwrap_2_1_96 +tag = cismwrap_2_1_100 protocol = git repo_url = https://github.com/ESCOMP/CISM-wrapper local_path = components/cism @@ -79,7 +72,7 @@ externals = Externals_CISM.cfg required = True [clm] -tag = ctsm5.1.dev145 +tag = ctsm5.2.005 protocol = git repo_url = https://github.com/ESCOMP/CTSM local_path = components/clm @@ -95,14 +88,14 @@ externals = Externals_FMS.cfg required = True [mosart] -tag = mosart1_0_48 +tag = mosart1_0_49 protocol = git repo_url = https://github.com/ESCOMP/MOSART local_path = components/mosart required = True [rtm] -tag = rtm1_0_78 +tag = rtm1_0_79 protocol = git repo_url = https://github.com/ESCOMP/RTM local_path = components/rtm diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 05983cca7b..98813e6993 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1444,7 +1444,7 @@ - + From 1f0df194d83cc5d83aa88a9016f3f2c96f9d5780 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Tue, 14 May 2024 11:22:48 -0600 Subject: [PATCH 27/75] put back in MCT since makefile mods would be required --- Externals.cfg | 7 +++++++ cime_config/testdefs/testlist_cam.xml | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Externals.cfg b/Externals.cfg index f967878539..ad6907e697 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -49,6 +49,13 @@ repo_url = https://github.com/ESCOMP/CESM_share local_path = share required = True +[mct] +tag = MCT_2.11.0 +protocol = git +repo_url = https://github.com/MCSclimate/MCT +local_path = libraries/mct +required = True + [parallelio] tag = pio2_6_2 protocol = git diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 98813e6993..05983cca7b 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1444,7 +1444,7 @@ - + From 93aa30e7ed2d4c31ab94b5bf4f310ebe8f81e343 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Tue, 14 May 2024 15:49:34 -0600 Subject: [PATCH 28/75] Increase wall clock times --- cime_config/testdefs/testlist_cam.xml | 28 +++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 05983cca7b..575729a37c 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -73,7 +73,7 @@ - + @@ -83,7 +83,7 @@ - + @@ -93,7 +93,7 @@ - + @@ -1811,7 +1811,7 @@ - + @@ -1829,7 +1829,7 @@ - + @@ -2033,7 +2033,7 @@ - + @@ -2390,7 +2390,7 @@ - + @@ -2415,7 +2415,7 @@ - + @@ -2424,7 +2424,7 @@ - + @@ -2450,7 +2450,7 @@ - + @@ -2459,7 +2459,7 @@ - + @@ -2725,7 +2725,7 @@ - + @@ -2748,7 +2748,7 @@ - + @@ -2800,7 +2800,7 @@ - + From e91606adb14eb836d8218abb4f239076810d05d3 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Thu, 16 May 2024 13:08:22 -0600 Subject: [PATCH 29/75] revert times back for regression tests to original times --- cime_config/testdefs/testlist_cam.xml | 28 +++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 575729a37c..05983cca7b 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -73,7 +73,7 @@ - + @@ -83,7 +83,7 @@ - + @@ -93,7 +93,7 @@ - + @@ -1811,7 +1811,7 @@ - + @@ -1829,7 +1829,7 @@ - + @@ -2033,7 +2033,7 @@ - + @@ -2390,7 +2390,7 @@ - + @@ -2415,7 +2415,7 @@ - + @@ -2424,7 +2424,7 @@ - + @@ -2450,7 +2450,7 @@ - + @@ -2459,7 +2459,7 @@ - + @@ -2725,7 +2725,7 @@ - + @@ -2748,7 +2748,7 @@ - + @@ -2800,7 +2800,7 @@ - + From f816d1e560281734e3106a74cfa860484f5fb6a4 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Thu, 16 May 2024 16:34:40 -0600 Subject: [PATCH 30/75] ChangeLog for cam6_3_161 --- doc/ChangeLog | 115 +++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 114 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 9f4f0d348d..3a5c46527d 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,6 +1,120 @@ =============================================================== +Tag name: cam6_3_161 +Originator(s): cacraig +Date: May 16, 2024 +One-line Summary: Update to alpha17 externals +Github PR URL: https://github.com/ESCOMP/CAM/pull/1031 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Update externals to match externals which will be used in cesm2_3_beta17: https://github.com/ESCOMP/CAM/issues/985 + - Bring in ccs_config0.0.99: https://github.com/ESCOMP/CAM/issues/1021 + - Unable to compile cam6_3_154 with nvhpc/24.3 on Derecho: https://github.com/ESCOMP/CAM/issues/1025 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M Externals.cfg + - update externals to match cesm2_3_beta17 + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +NOTE - most tests have namelist differences due to mediator namelist changes + +derecho/intel/aux_cam: + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure + + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: FAIL) details: + - Bug during CREATE_NEWCASE in CTSM code - will go away when CTSM external is updated post git-fleximod + + SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - Bug in med.F90 - Will go away when CICE external is updated post git-fleximod + + ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + FAIL ERP_Ln9.ne30_ne30_mg17.FCnudged.derecho_intel.cam-outfrq9s SHAREDLIB_BUILD failed to initialize + SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: PEND) details: + PEND SMS_D_Ln9.ne16_ne16_mg17.FX2000.derecho_intel.cam-outfrq9s SHAREDLIB_BUILD + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + FAIL SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s SHAREDLIB_BUILD time=2 + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + FAIL SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s SHAREDLIB_BUILD time=1 + - Bugs reported to CTSM and will be fixed when CTSM external is updated post git-fleximod + + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.F2000dev.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000dev.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam_dev (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FSPCAMS.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Answer changes due to updated externals + +izumi/nag/aux_cam: all B4B, except: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure + +izumi/gnu/aux_cam: all BFB except: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: FAIL) details: + - Bug during CREATE_NEWCASE in CTSM code - will go away when CTSM external is updated post git-fleximod + + SMS_D_Ln9.f10_f10_mg37.2000_CAM%DEV%GHGMAM4_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_SESP.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - answer changes due to updated externals + + +CAM tag used for the baseline comparison tests if different than previous +tag: cam6_3_159 as cam6_3_160 did not run regression tests + + +=============================================================== +=============================================================== + Tag name: cam6_3_160 Originator(s): cacraig, jedwards Date: April 29, 2024 @@ -461,7 +575,6 @@ derecho/intel/aux_cam: SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: SMS_Ld1.f19_f19.F2000dev.derecho_intel.cam-outfrq1d (Overall: DIFF) details: SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: - SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: From 4fc504cd98d51f10e4c3a544172c1f3dea08f98f Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Tue, 21 May 2024 11:29:39 -0600 Subject: [PATCH 31/75] remove the casper test suites --- cime_config/testdefs/testlist_cam.xml | 45 ------------------- .../cam/outfrq9s_mg2_default/shell_commands | 7 --- .../cam/outfrq9s_mg2_default/user_nl_cam | 4 -- .../cam/outfrq9s_mg2_default/user_nl_clm | 26 ----------- .../outfrq9s_mg3_nondefault/shell_commands | 8 ---- .../cam/outfrq9s_mg3_nondefault/user_nl_cam | 24 ---------- .../cam/outfrq9s_mg3_nondefault/user_nl_clm | 26 ----------- .../cam/outfrq9s_mg3_pcols1536/shell_commands | 8 ---- .../cam/outfrq9s_mg3_pcols1536/user_nl_cam | 4 -- .../cam/outfrq9s_mg3_pcols1536/user_nl_clm | 26 ----------- 10 files changed, 178 deletions(-) delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/shell_commands delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_cam delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_clm delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/shell_commands delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_cam delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_clm delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/shell_commands delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_cam delete mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_clm diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 05983cca7b..cd4b65be41 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1569,51 +1569,6 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/shell_commands deleted file mode 100644 index 89516e5375..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/shell_commands +++ /dev/null @@ -1,7 +0,0 @@ -./xmlchange NTASKS=36 -./xmlchange NTHRDS=1 -./xmlchange ROOTPE='0' -./xmlchange ROF_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange GLC_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange TIMER_DETAIL='6' -./xmlchange TIMER_LEVEL='999' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_cam deleted file mode 100644 index 8482082dce..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_cam +++ /dev/null @@ -1,4 +0,0 @@ -mfilt=1,1,1,1,1,1 -ndens=1,1,1,1,1,1 -nhtfrq=9,9,9,9,9,9 -inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_clm deleted file mode 100644 index 12d5a36d2b..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/user_nl_clm +++ /dev/null @@ -1,26 +0,0 @@ -!---------------------------------------------------------------------------------- -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value -! -! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options -! are set in the CLM_NAMELIST_OPTS env variable. -! -! EXCEPTIONS: -! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting -! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting -! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting -! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting -! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting -! Set irrigate by the CLM_BLDNML_OPTS -irrig setting -! Set dtime with L_NCPL option -! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options -! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases -! (includes $inst_string for multi-ensemble cases) -! Set glc_grid with CISM_GRID option -! Set glc_smb with GLC_SMB option -! Set maxpatch_glcmec with GLC_NEC option -! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable -!---------------------------------------------------------------------------------- -hist_nhtfrq = 9 -hist_mfilt = 1 -hist_ndens = 1 diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/shell_commands deleted file mode 100644 index 9fdcee8bfd..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/shell_commands +++ /dev/null @@ -1,8 +0,0 @@ -./xmlchange NTASKS=36 -./xmlchange NTHRDS=1 -./xmlchange ROOTPE='0' -./xmlchange ROF_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange GLC_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange CAM_CONFIG_OPTS=' -microphys mg3' --append -./xmlchange TIMER_DETAIL='6' -./xmlchange TIMER_LEVEL='999' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_cam deleted file mode 100644 index 8bb09f9ffc..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_cam +++ /dev/null @@ -1,24 +0,0 @@ -mfilt=1,1,1,1,1,1 -ndens=1,1,1,1,1,1 -nhtfrq=9,9,9,9,9,9 -inithist='ENDOFRUN' -micro_mg_do_graupel=.false. -micro_mg_do_hail=.true. -micro_do_sb_physics=.true. -micro_do_massless_droplet_destroyer=.true. -microp_uniform=.true. -micro_mg_nccons=.true. -micro_mg_nicons=.true. -micro_mg_ngcons=.true. -micro_mg_nrcons=.true. -micro_mg_nscons=.true. -micro_mg_evap_sed_off=.true. -micro_mg_icenuc_rh_off=.true. -micro_mg_icenuc_use_meyers=.true. -micro_mg_evap_scl_ifs=.true. -micro_mg_evap_rhthrsh_ifs=.true. -micro_mg_rainfreeze_ifs=.true. -micro_mg_ifs_sed=.true. -micro_mg_precip_fall_corr=.true. -micro_mg_implicit_fall=.false. -micro_mg_accre_sees_auto=.true. diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_clm deleted file mode 100644 index 12d5a36d2b..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_clm +++ /dev/null @@ -1,26 +0,0 @@ -!---------------------------------------------------------------------------------- -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value -! -! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options -! are set in the CLM_NAMELIST_OPTS env variable. -! -! EXCEPTIONS: -! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting -! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting -! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting -! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting -! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting -! Set irrigate by the CLM_BLDNML_OPTS -irrig setting -! Set dtime with L_NCPL option -! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options -! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases -! (includes $inst_string for multi-ensemble cases) -! Set glc_grid with CISM_GRID option -! Set glc_smb with GLC_SMB option -! Set maxpatch_glcmec with GLC_NEC option -! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable -!---------------------------------------------------------------------------------- -hist_nhtfrq = 9 -hist_mfilt = 1 -hist_ndens = 1 diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/shell_commands deleted file mode 100644 index d6e6750eb4..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/shell_commands +++ /dev/null @@ -1,8 +0,0 @@ -./xmlchange NTASKS=36 -./xmlchange NTHRDS=1 -./xmlchange ROOTPE='0' -./xmlchange ROF_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange GLC_NCPL=`./xmlquery --value ATM_NCPL` -./xmlchange CAM_CONFIG_OPTS=' -microphys mg3 -pcols 1536' --append -./xmlchange TIMER_DETAIL='6' -./xmlchange TIMER_LEVEL='999' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_cam deleted file mode 100644 index 8482082dce..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_cam +++ /dev/null @@ -1,4 +0,0 @@ -mfilt=1,1,1,1,1,1 -ndens=1,1,1,1,1,1 -nhtfrq=9,9,9,9,9,9 -inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_clm deleted file mode 100644 index 12d5a36d2b..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/user_nl_clm +++ /dev/null @@ -1,26 +0,0 @@ -!---------------------------------------------------------------------------------- -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value -! -! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options -! are set in the CLM_NAMELIST_OPTS env variable. -! -! EXCEPTIONS: -! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting -! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting -! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting -! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting -! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting -! Set irrigate by the CLM_BLDNML_OPTS -irrig setting -! Set dtime with L_NCPL option -! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options -! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases -! (includes $inst_string for multi-ensemble cases) -! Set glc_grid with CISM_GRID option -! Set glc_smb with GLC_SMB option -! Set maxpatch_glcmec with GLC_NEC option -! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable -!---------------------------------------------------------------------------------- -hist_nhtfrq = 9 -hist_mfilt = 1 -hist_ndens = 1 From e79c4a388ea7c51286a339e3c6baf9100e263842 Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Tue, 21 May 2024 11:40:49 -0600 Subject: [PATCH 32/75] add GPU test suite on Derecho --- cime_config/testdefs/testlist_cam.xml | 16 ++++++++++++ .../cam/outfrq9s_mg3_default/shell_commands | 2 +- .../cam/outfrq9s_mg3_pcols760/shell_commands | 8 ++++++ .../cam/outfrq9s_mg3_pcols760/user_nl_cam | 4 +++ .../cam/outfrq9s_mg3_pcols760/user_nl_clm | 26 +++++++++++++++++++ 5 files changed, 55 insertions(+), 1 deletion(-) create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/shell_commands create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_cam create mode 100644 cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_clm diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index cd4b65be41..d464d825d1 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1485,6 +1485,22 @@ + + + + + + + + + + + + + + + + diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_default/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_default/shell_commands index 9fdcee8bfd..23dac55242 100644 --- a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_default/shell_commands +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_default/shell_commands @@ -1,4 +1,4 @@ -./xmlchange NTASKS=36 +./xmlchange NTASKS=128 ./xmlchange NTHRDS=1 ./xmlchange ROOTPE='0' ./xmlchange ROF_NCPL=`./xmlquery --value ATM_NCPL` diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/shell_commands b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/shell_commands new file mode 100644 index 0000000000..f9424e5025 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/shell_commands @@ -0,0 +1,8 @@ +./xmlchange NTASKS=64 +./xmlchange NTHRDS=1 +./xmlchange ROOTPE='0' +./xmlchange ROF_NCPL=`./xmlquery --value ATM_NCPL` +./xmlchange GLC_NCPL=`./xmlquery --value ATM_NCPL` +./xmlchange CAM_CONFIG_OPTS=' -microphys mg3 -pcols 760 ' --append +./xmlchange TIMER_DETAIL='6' +./xmlchange TIMER_LEVEL='999' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_cam new file mode 100644 index 0000000000..8482082dce --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_cam @@ -0,0 +1,4 @@ +mfilt=1,1,1,1,1,1 +ndens=1,1,1,1,1,1 +nhtfrq=9,9,9,9,9,9 +inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_clm new file mode 100644 index 0000000000..12d5a36d2b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760/user_nl_clm @@ -0,0 +1,26 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options +! are set in the CLM_NAMELIST_OPTS env variable. +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig setting +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! Set glc_grid with CISM_GRID option +! Set glc_smb with GLC_SMB option +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- +hist_nhtfrq = 9 +hist_mfilt = 1 +hist_ndens = 1 From e779d59601195b6f8ac8d0eea5980f3b055c13eb Mon Sep 17 00:00:00 2001 From: Jian Sun Date: Fri, 24 May 2024 13:37:05 -0600 Subject: [PATCH 33/75] swithc ERP to ERS test as nvhpc seems to have a bug with openmp threading --- cime_config/testdefs/testlist_cam.xml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index d464d825d1..12e7648a91 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1485,7 +1485,7 @@ - + @@ -1493,14 +1493,14 @@ - + - + From f088d526f274cfa3e27acad63011412ca232f5f5 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 30 May 2024 17:09:30 -0600 Subject: [PATCH 34/75] change dir name from dadadj to dry_adiabatic_adjust and make sure new name is in Filepath --- bld/configure | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/bld/configure b/bld/configure index 05f1d7155c..0030d6a83a 100755 --- a/bld/configure +++ b/bld/configure @@ -2304,7 +2304,7 @@ sub write_filepath #Add the CCPP'ized subdirectories print $fh "$camsrcdir/src/atmos_phys/zhang_mcfarlane\n"; - print $fh "$camsrcdir/src/atmos_phys/dadadj\n"; + print $fh "$camsrcdir/src/atmos_phys/dry_adiabatic_adjust\n"; # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; From b9003c2651a01e173a4dcde48f510b4b01c62b36 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Tue, 4 Jun 2024 12:24:15 -0600 Subject: [PATCH 35/75] PR update to err message for convergence failure --- src/physics/cam/dadadj_cam.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/physics/cam/dadadj_cam.F90 b/src/physics/cam/dadadj_cam.F90 index d12c307ac9..2a7e09014e 100644 --- a/src/physics/cam/dadadj_cam.F90 +++ b/src/physics/cam/dadadj_cam.F90 @@ -132,11 +132,16 @@ subroutine dadadj_tend(dt, state, ptend) ncol, dt, state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), state%t(:ncol,:), state%q(:ncol,:,1), cappav(:ncol,:,lchnk), & ptend%s(:ncol,:), ptend%q(:ncol,:,1), dadpdf(:ncol,:), scheme_name, errmsg, errflg) + ! error exit if (errflg /= 0) then - ! error exit - write(errstring, *) errmsg,' at lat,lon:', & - state%lat(errflg)*180._r8/pi, state%lon(errflg)*180._r8/pi - call endrun('dadadj_tend: Error returned from dadadj_run: '//trim(errstring)) + ! If this is a Convergence error then output lat lon of problem column using column index (errflg) + if(index('Convergence', errmsg) /= 0)then + write(errstring, *) trim(adjustl(errmsg)),' lat:',state%lat(errflg)*180._r8/pi,' lon:', & + state%lon(errflg)*180._r8/pi + else + errstring=trim(errmsg) + end if + call endrun('Error dadadj_tend:'//trim(errstring)) end if call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) From 1698a761ac5dd562bd96975a8636d13465831283 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 20 Jun 2024 15:42:08 -0600 Subject: [PATCH 36/75] initialize snapshot outfld fields to 0 in tphysac and tphysbc --- Externals.cfg | 4 ++-- src/physics/cam/physpkg.F90 | 32 ++++++++++++++++---------------- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index ffe2c4b012..776dac5899 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -64,9 +64,9 @@ local_path = libraries/parallelio required = True [cime] -tag = cime6.0.236_httpsbranch01 +tag = stdname_xsd protocol = git -repo_url = https://github.com/ESMCI/cime +repo_url = https://github.com/jtruesdal/cime local_path = cime required = True diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 883b774fd1..720a24286e 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -1463,10 +1463,10 @@ subroutine tphysac (ztodt, cam_in, & logical :: labort ! abort flag - real(r8) surfric(pcols) ! surface friction velocity - real(r8) obklen(pcols) ! Obukhov length - real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. + real(r8) :: surfric(pcols) = 0._r8 ! surface friction velocity + real(r8) :: obklen(pcols) = 0._r8 ! Obukhov length + real(r8) :: fh2o(pcols) = 0._r8 ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) = 0._r8 ! Heat flux for check_energy_chng. real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space real(r8) :: tmp_ps (pcols) ! tmp space @@ -2117,15 +2117,15 @@ subroutine tphysbc (ztodt, state, & integer :: nstep ! current timestep number - real(r8) :: net_flx(pcols) + real(r8) :: net_flx(pcols) = 0._r8 - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + real(r8) :: zdu(pcols,pver) = 0._r8 ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + real(r8) cmfcme(pcols,pver) = 0._r8 ! cmf condensation - evaporation - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow convections real(r8) rtdt ! 1./ztodt integer lchnk ! chunk identifier @@ -2187,13 +2187,13 @@ subroutine tphysbc (ztodt, state, & ! energy checking variables real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: rliq(pcols) = 0._r8 ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) = 0._r8 ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) = 0._r8 ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) = 0._r8 ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) = 0._r8 ! vertical integral of detrained ice real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) + real(r8) :: flx_heat(pcols) = 0._r8 type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes real(r8) :: zero_tracers(pcols,pcnst) From cbc9ce52d255aee5c277462fb70ec84fa0a83987 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 21 Jun 2024 09:34:34 -0600 Subject: [PATCH 37/75] update to cam6_3_162 w git-fleximod --- .gitmodules | 4 +- bld/configure | 1 + src/atmos_phys | 2 +- src/physics/cam/dadadj_cam.F90 | 103 +++++++++++++++++++------------- src/physics/cam/physpkg.F90 | 56 ++++++++--------- src/physics/cam_dev/physpkg.F90 | 58 +++++++++--------- 6 files changed, 117 insertions(+), 107 deletions(-) diff --git a/.gitmodules b/.gitmodules index 77e9c2fc56..5911569d46 100644 --- a/.gitmodules +++ b/.gitmodules @@ -35,8 +35,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/ESCOMP/atmospheric_physics - fxtag = atmos_phys0_02_006 + url = https://github.com/jtruesdal/atmospheric_physics + fxtag = dadadj fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/bld/configure b/bld/configure index e2fb784495..0030d6a83a 100755 --- a/bld/configure +++ b/bld/configure @@ -2304,6 +2304,7 @@ sub write_filepath #Add the CCPP'ized subdirectories print $fh "$camsrcdir/src/atmos_phys/zhang_mcfarlane\n"; + print $fh "$camsrcdir/src/atmos_phys/dry_adiabatic_adjust\n"; # Dynamics package and test utilities print $fh "$camsrcdir/src/dynamics/$dyn\n"; diff --git a/src/atmos_phys b/src/atmos_phys index 4944547f04..4c0f72356a 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 4944547f04b1457d78bf7d3c0becddcfe0deabb9 +Subproject commit 4c0f72356afa6c5453b4b21a9fb041b3a3ac155c diff --git a/src/physics/cam/dadadj_cam.F90 b/src/physics/cam/dadadj_cam.F90 index 0717865ca8..2a7e09014e 100644 --- a/src/physics/cam/dadadj_cam.F90 +++ b/src/physics/cam/dadadj_cam.F90 @@ -2,7 +2,7 @@ module dadadj_cam ! CAM interfaces for the dry adiabatic adjustment parameterization -use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs +use shr_kind_mod, only: r8=>shr_kind_r8, cs=>shr_kind_cs, cm=>shr_kind_cm use ppgrid, only: pcols, pver, pverp use constituents, only: pcnst use air_composition, only: cappav, cpairv @@ -17,7 +17,7 @@ module dadadj_cam use namelist_utils, only: find_group_name use units, only: getunit, freeunit -use dadadj, only: dadadj_initial, dadadj_calc +use dadadj, only: dadadj_init, dadadj_run implicit none private @@ -25,7 +25,7 @@ module dadadj_cam public :: & dadadj_readnl, & - dadadj_init, & + dadadj_cam_init, & dadadj_tend ! Namelist variables @@ -42,8 +42,10 @@ subroutine dadadj_readnl(filein) namelist /dadadj_nl/ dadadj_nlvdry, dadadj_niter - integer :: unitn, ierr - character(len=*), parameter :: sub='dadadj_readnl' + integer :: unitn, ierr + integer :: errflg ! CCPP physics scheme error flag + character(len=512) :: errmsg ! CCPP physics scheme error message + character(len=*), parameter :: sub='dadadj_readnl' !------------------------------------------------------------------ ! Read namelist @@ -67,13 +69,16 @@ subroutine dadadj_readnl(filein) call mpibcast(dadadj_niter, 1, mpi_integer, masterprocid, mpicom) #endif - call dadadj_initial(dadadj_nlvdry, dadadj_niter) + call dadadj_init(dadadj_nlvdry, dadadj_niter, pver, errmsg, errflg) + if (errflg /=0) then + call endrun('dadadj_readnl: Error returned from dadadj_init: '//trim(errmsg)) + end if if (masterproc .and. .not. use_simple_phys) then write(iulog,*)'Dry adiabatic adjustment applied to top N layers; N=', & - dadadj_nlvdry + dadadj_nlvdry write(iulog,*)'Dry adiabatic adjustment number of iterations for convergence =', & - dadadj_niter + dadadj_niter end if end subroutine dadadj_readnl @@ -81,12 +86,12 @@ end subroutine dadadj_readnl !=============================================================================== -subroutine dadadj_init() +subroutine dadadj_cam_init() use cam_history, only: addfld call addfld('DADADJ_PD', (/ 'lev' /), 'A', 'probability', 'dry adiabatic adjustment probability') -end subroutine dadadj_init +end subroutine dadadj_cam_init !=============================================================================== @@ -98,39 +103,51 @@ subroutine dadadj_tend(dt, state, ptend) type(physics_state), intent(in) :: state ! Physics state variables type(physics_ptend), intent(out) :: ptend ! parameterization tendencies - logical :: lq(pcnst) - real(r8) :: dadpdf(pcols, pver) - integer :: ncol, lchnk, icol_err - character(len=128) :: errstring ! Error string - - ncol = state%ncol - lchnk = state%lchnk - lq(:) = .FALSE. - lq(1) = .TRUE. - call physics_ptend_init(ptend, state%psetcols, 'dadadj', ls=.true., lq=lq) - - ! use the ptend components for temporary storate and copy state info for input to - ! dadadj_calc which directly updates the temperature and moisture input arrays. - - ptend%s(:ncol,:pver) = state%t(:ncol,:pver) - ptend%q(:ncol,:pver,1) = state%q(:ncol,:pver,1) - - call dadadj_calc( & - ncol, state%pmid, state%pint, state%pdel, cappav(:,:,lchnk), ptend%s, & - ptend%q(:,:,1), dadpdf, icol_err) - - call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) - - if (icol_err > 0) then - ! error exit - write(errstring, *) & - 'dadadj_calc: No convergence in column at lat,lon:', & - state%lat(icol_err)*180._r8/pi, state%lon(icol_err)*180._r8/pi - call handle_errmsg(errstring, subname="dadadj_tend") - end if - - ptend%s(:ncol,:) = (ptend%s(:ncol,:) - state%t(:ncol,:) )/dt * cpairv(:ncol,:,lchnk) - ptend%q(:ncol,:,1) = (ptend%q(:ncol,:,1) - state%q(:ncol,:,1))/dt + character(len=512) :: errstring ! Error string + character(len=512) :: errmsg ! CCPP physics scheme error message + character(len=64) :: scheme_name! CCPP physics scheme name (not used in CAM) + integer :: icol_err + integer :: lchnk + integer :: ncol + integer :: errflg ! CCPP physics scheme error flag + logical :: lq(pcnst) + real(r8) :: dadpdf(pcols, pver) + + !------------------------------------------------------------------ + ncol = state%ncol + lchnk = state%lchnk + lq(:) = .FALSE. + lq(1) = .TRUE. + call physics_ptend_init(ptend, state%psetcols, 'dadadj', ls=.true., lq=lq) + + !REMOVECAM - no longer need these when CAM is retired and pcols no longer exists + dadpdf = 0._r8 + ptend%s = 0._r8 + ptend%q = 0._r8 + !REMOVECAM_END + + ! dadadj_run returns t tend, we are passing the ptend%s array to receive the t tendency and will convert it to s + ! before it is returned to CAM.. + call dadadj_run( & + ncol, dt, state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), state%t(:ncol,:), state%q(:ncol,:,1), cappav(:ncol,:,lchnk), & + ptend%s(:ncol,:), ptend%q(:ncol,:,1), dadpdf(:ncol,:), scheme_name, errmsg, errflg) + + ! error exit + if (errflg /= 0) then + ! If this is a Convergence error then output lat lon of problem column using column index (errflg) + if(index('Convergence', errmsg) /= 0)then + write(errstring, *) trim(adjustl(errmsg)),' lat:',state%lat(errflg)*180._r8/pi,' lon:', & + state%lon(errflg)*180._r8/pi + else + errstring=trim(errmsg) + end if + call endrun('Error dadadj_tend:'//trim(errstring)) + end if + + call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) + + ! convert the t tendency to an s tendency for cam + ptend%s(:ncol,:) = ptend%s(:ncol,:) * cpairv(:ncol,:,lchnk) end subroutine dadadj_tend diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index cb7322254f..13dc3eb6bb 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -777,7 +777,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use sslt_rebin, only: sslt_rebin_init use tropopause, only: tropopause_init use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_init + use dadadj_cam, only: dadadj_cam_init use cam_abortutils, only: endrun use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init @@ -952,7 +952,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) #endif call sslt_rebin_init() call tropopause_init() - call dadadj_init() + call dadadj_cam_init() prec_dp_idx = pbuf_get_index('PREC_DP') snow_dp_idx = pbuf_get_index('SNOW_DP') @@ -1463,10 +1463,10 @@ subroutine tphysac (ztodt, cam_in, & logical :: labort ! abort flag - real(r8) surfric(pcols) ! surface friction velocity - real(r8) obklen(pcols) ! Obukhov length - real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. + real(r8) :: surfric(pcols) = 0._r8 ! surface friction velocity + real(r8) :: obklen(pcols) = 0._r8 ! Obukhov length + real(r8) :: fh2o(pcols) = 0._r8 ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) = 0._r8 ! Heat flux for check_energy_chng. real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space real(r8) :: tmp_ps (pcols) ! tmp space @@ -2117,26 +2117,22 @@ subroutine tphysbc (ztodt, state, & integer :: nstep ! current timestep number - real(r8) :: net_flx(pcols) - - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) rtdt ! 1./ztodt - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + real(r8) :: net_flx(pcols) = 0._r8 + real(r8) :: zdu(pcols,pver) = 0._r8 ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c + real(r8) :: cmfcme(pcols,pver) = 0._r8 ! cmf condensation - evaporation + real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections + real(r8) :: dlf2(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow convections + real(r8) :: rtdt ! 1./ztodt + + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. integer :: m, m_cnst ! for macro/micro co-substepping - integer :: macmic_it ! iteration variables - real(r8) :: cld_macmic_ztodt ! modified timestep + integer :: macmic_it ! iteration variables + real(r8) :: cld_macmic_ztodt ! modified timestep ! physics buffer fields to compute tendencies for stratiform package integer itim_old, ifld real(r8), pointer, dimension(:,:) :: cld ! cloud fraction @@ -2187,13 +2183,13 @@ subroutine tphysbc (ztodt, state, & ! energy checking variables real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: rliq(pcols) = 0._r8 ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) = 0._r8 ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) = 0._r8 ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) = 0._r8 ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) = 0._r8 ! vertical integral of detrained ice real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) + real(r8) :: flx_heat(pcols) = 0._r8 type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes real(r8) :: zero_tracers(pcols,pcnst) diff --git a/src/physics/cam_dev/physpkg.F90 b/src/physics/cam_dev/physpkg.F90 index aef997716f..82f4065fba 100644 --- a/src/physics/cam_dev/physpkg.F90 +++ b/src/physics/cam_dev/physpkg.F90 @@ -761,7 +761,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) use clubb_intr, only: clubb_ini_cam use tropopause, only: tropopause_init use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_init + use dadadj_cam, only: dadadj_cam_init use cam_abortutils, only: endrun use nudging, only: Nudge_Model, nudging_init use cam_snapshot, only: cam_snapshot_init @@ -920,7 +920,7 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_in, cam_out ) call metdata_phys_init() #endif call tropopause_init() - call dadadj_init() + call dadadj_cam_init() prec_dp_idx = pbuf_get_index('PREC_DP') snow_dp_idx = pbuf_get_index('SNOW_DP') @@ -1448,16 +1448,16 @@ subroutine tphysac (ztodt, cam_in, & integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep - real(r8) :: net_flx(pcols) + real(r8) :: net_flx(pcols) = 0._r8 - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) rtdt ! 1./ztodt + real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections + real(r8) :: rtdt ! 1./ztodt real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice + real(r8) :: det_s (pcols) = 0._r8 ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) = 0._r8 ! vertical integral of detrained ice real(r8) :: flx_cnd(pcols) real(r8) :: zero_sc(pcols*psubcols) ! array of zeros @@ -1489,12 +1489,12 @@ subroutine tphysac (ztodt, cam_in, & logical :: labort ! abort flag - real(r8) tvm(pcols,pver) ! virtual temperature - real(r8) prect(pcols) ! total precipitation - real(r8) surfric(pcols) ! surface friction velocity - real(r8) obklen(pcols) ! Obukhov length - real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. + real(r8) :: tvm(pcols,pver) ! virtual temperature + real(r8) :: prect(pcols) ! total precipitation + real(r8) :: surfric(pcols) = 0._r8 ! surface friction velocity + real(r8) :: obklen(pcols) = 0._r8 ! Obukhov length + real(r8) :: fh2o(pcols) = 0._r8 ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) = 0._r8 ! Heat flux for check_energy_chng. real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space real(r8) :: tmp_ps (pcols) ! tmp space @@ -2534,22 +2534,18 @@ subroutine tphysbc (ztodt, state, & integer :: nstep ! current timestep number - real(r8) :: net_flx(pcols) + real(r8) :: net_flx(pcols) = 0._r8 + real(r8) :: zdu(pcols,pver) = 0._r8 ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c + real(r8) :: cmfcme(pcols,pver) = 0._r8 ! cmf condensation - evaporation + real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections + real(r8) :: dlf2(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow convections + real(r8) :: rtdt ! 1./ztodt - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) rtdt ! 1./ztodt - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. integer :: m, m_cnst ! physics buffer fields to compute tendencies for stratiform package @@ -2593,8 +2589,8 @@ subroutine tphysbc (ztodt, state, & real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: rice(pcols) = 0._r8 ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) = 0._r8 ! vertical integral of liquid from shallow scheme real(r8) :: flx_cnd(pcols) real(r8) :: flx_heat(pcols) type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes From 871336fe1943562556e45def37becc21297c455b Mon Sep 17 00:00:00 2001 From: Katetc Date: Tue, 25 Jun 2024 15:29:03 -0600 Subject: [PATCH 38/75] Updates for the new external --- .gitmodules | 2 +- bld/namelist_files/namelist_defaults_cam.xml | 4 + src/physics/cam/clubb_intr.F90 | 324 +++++++++++-------- src/physics/cam/subcol_SILHS.F90 | 162 +++++----- 4 files changed, 286 insertions(+), 206 deletions(-) diff --git a/.gitmodules b/.gitmodules index 77e9c2fc56..87a783bf6f 100644 --- a/.gitmodules +++ b/.gitmodules @@ -96,7 +96,7 @@ url = https://github.com/larson-group/clubb_release fxrequired = AlwaysRequired fxsparse = ../.clubb_sparse_checkout - fxtag = clubb_4ncar_20231115_5406350 + fxtag = clubb_4ncar_20240605_73d60f6 fxDONOTUSEurl = https://github.com/larson-group/clubb_release [submodule "cism"] diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 331863e4e2..247bacf527 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -2236,6 +2236,7 @@ .false. .true. .true. + .true. 0.2 @@ -2261,6 +2262,7 @@ 10.0 4.0 0.0 + 5.0 .true. .false. @@ -2279,6 +2281,8 @@ .false. .false. .false. + 0.5 + 25.00 diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index c5bdcd71ce..ce8c14e096 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -31,8 +31,10 @@ module clubb_intr #ifdef CLUBB_SGS use clubb_api_module, only: pdf_parameter, implicit_coefs_terms - use clubb_api_module, only: clubb_config_flags_type, grid, stats, & - nu_vertical_res_dep, stats_metadata_type + use clubb_api_module, only: clubb_config_flags_type, grid, stats, & + nu_vertical_res_dep, stats_metadata_type, & + hm_metadata_type, sclr_idx_type + use clubb_api_module, only: nparams use clubb_mf, only: do_clubb_mf, do_clubb_mf_diag use cloud_fraction, only: dp1, dp2 @@ -51,6 +53,17 @@ module clubb_intr type (stats_metadata_type) :: & stats_metadata +!$omp threadprivate(stats_metadata) + + type (hm_metadata_type) :: & + hm_metadata + +!$omp threadprivate(hm_metadata) + + type (sclr_idx_type) :: & + sclr_idx + +!$omp threadprivate(sclr_idx) #endif @@ -84,7 +97,30 @@ module clubb_intr #ifdef CLUBB_SGS type(clubb_config_flags_type), public :: clubb_config_flags - real(r8), dimension(nparams), public :: clubb_params ! Adjustable CLUBB parameters (C1, C2 ...) + real(r8), dimension(nparams), public :: clubb_params_single_col ! Adjustable CLUBB parameters (C1, C2 ...) +#endif + + ! These are zero by default, but will be set by SILHS before + integer :: & + hydromet_dim = 0, & + pdf_dim = 0 + + + ! ------------------------ ! + ! Sometimes private data ! + ! ------------------------ ! +#ifdef SILHS + ! If SILHS is in use, it will initialize these + public :: & + hydromet_dim, & + pdf_dim, & + hm_metadata +#else + ! If SILHS is not in use, there is no need for them to be public + private :: & + hydromet_dim, & + pdf_dim, & + hm_metadata #endif ! ------------ ! @@ -93,23 +129,18 @@ module clubb_intr integer, parameter :: & grid_type = 3, & ! The 2 option specifies stretched thermodynamic levels - hydromet_dim = 0 ! The hydromet array in SAM-CLUBB is currently 0 elements + sclr_dim = 0 ! Higher-order scalars, set to zero ! Even though sclr_dim is set to 0, the dimension here is set to 1 to prevent compiler errors ! See github ticket larson-group/cam#133 for details real(r8), parameter, dimension(1) :: & sclr_tol = 1.e-8_r8 ! Total water in kg/kg - character(len=6) :: saturation_equation - real(r8), parameter :: & theta0 = 300._r8, & ! Reference temperature [K] ts_nudge = 86400._r8, & ! Time scale for u/v nudging (not used) [s] p0_clubb = 100000._r8 - integer, parameter :: & - sclr_dim = 0 ! Higher-order scalars, set to zero - real(r8), parameter :: & wp3_const = 1._r8 ! Constant to add to wp3 when moments are advected @@ -195,8 +226,8 @@ module clubb_intr clubb_ipdf_call_placement = unset_i, & ! Selected option for the placement of the call to ! CLUBB's PDF. clubb_penta_solve_method = unset_i, & ! Specifier for method to solve the penta-diagonal system - clubb_tridiag_solve_method = unset_i ! Specifier for method to solve tri-diagonal systems - + clubb_tridiag_solve_method = unset_i,& ! Specifier for method to solve tri-diagonal systems + clubb_saturation_equation = unset_i ! Specifier for which saturation formula to use logical :: & @@ -315,13 +346,15 @@ module clubb_intr clubb_l_mono_flux_lim_vm, & ! Flag to turn on monotonic flux limiter for vm clubb_l_mono_flux_lim_spikefix, & ! Flag to implement monotonic flux limiter code that ! eliminates spurious drying tendencies at model top - clubb_l_intr_sfc_flux_smooth = .false. ! Add a locally calculated roughness to upwp and vpwp sfc fluxes + clubb_l_host_applies_sfc_fluxes ! Whether the host model applies the surface fluxes + + logical :: & + clubb_l_intr_sfc_flux_smooth = .false. ! Add a locally calculated roughness to upwp and vpwp sfc fluxes ! Constant parameters logical, parameter, private :: & - l_implemented = .true., & ! Implemented in a host model (always true) - l_host_applies_sfc_fluxes = .false. ! Whether the host model applies the surface fluxes - + l_implemented = .true. ! Implemented in a host model (always true) + logical, parameter, private :: & apply_to_heat = .false. ! Apply WACCM energy fixer to heat or not (.true. = yes (duh)) @@ -487,13 +520,8 @@ subroutine clubb_register_cam( ) history_budget_out = history_budget, & history_budget_histfile_num_out = history_budget_histfile_num, & do_hb_above_clubb_out = do_hb_above_clubb) - subcol_scheme = subcol_get_scheme() - if (trim(subcol_scheme) == 'SILHS') then - saturation_equation = "flatau" - else - saturation_equation = "gfdl" ! Goff & Gratch (1946) approximation for SVP - end if + subcol_scheme = subcol_get_scheme() if (clubb_do_adv) then cnst_names =(/'THLP2 ','RTP2 ','RTPTHLP','WPTHLP ','WPRTP ','WP2 ','WP3 ','UP2 ','VP2 '/) @@ -856,6 +884,7 @@ subroutine clubb_readnl(nlfile) clubb_ipdf_call_placement, & ! Out clubb_penta_solve_method, & ! Out clubb_tridiag_solve_method, & ! Out + clubb_saturation_equation, & ! Out clubb_l_use_precip_frac, & ! Out clubb_l_predict_upwp_vpwp, & ! Out clubb_l_min_wp2_from_corr_wx, & ! Out @@ -909,7 +938,8 @@ subroutine clubb_readnl(nlfile) clubb_l_mono_flux_lim_rtm, & ! Out clubb_l_mono_flux_lim_um, & ! Out clubb_l_mono_flux_lim_vm, & ! Out - clubb_l_mono_flux_lim_spikefix ) ! Out + clubb_l_mono_flux_lim_spikefix, & ! Out + clubb_l_host_applies_sfc_fluxes ) ! Out ! Call CLUBB+MF namelist call clubb_mf_readnl(nlfile) @@ -1158,10 +1188,14 @@ subroutine clubb_readnl(nlfile) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_mono_flux_lim_vm") call mpi_bcast(clubb_l_mono_flux_lim_spikefix, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_mono_flux_lim_spikefix") + call mpi_bcast(clubb_l_host_applies_sfc_fluxes, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_host_applies_sfc_fluxes") call mpi_bcast(clubb_penta_solve_method, 1, mpi_integer, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_penta_solve_method") call mpi_bcast(clubb_tridiag_solve_method, 1, mpi_integer, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_tridiag_solve_method") + call mpi_bcast(clubb_saturation_equation, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_saturation_equation") call mpi_bcast(clubb_l_intr_sfc_flux_smooth, 1, mpi_logical, mstrid, mpicom, ierr) if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: clubb_l_intr_sfc_flux_smooth") call mpi_bcast(clubb_l_vary_convect_depth, 1, mpi_logical, mstrid, mpicom, ierr) @@ -1267,6 +1301,7 @@ subroutine clubb_readnl(nlfile) if(clubb_detphase_lowtemp == unset_r8) call endrun(sub//": FATAL: clubb_detphase_lowtemp not set") if(clubb_penta_solve_method == unset_i) call endrun(sub//": FATAL: clubb_penta_solve_method not set") if(clubb_tridiag_solve_method == unset_i) call endrun(sub//": FATAL: clubb_tridiag_solve_method not set") + if(clubb_saturation_equation == unset_i) call endrun(sub//": FATAL: clubb_saturation_equation not set") if(clubb_detphase_lowtemp >= meltpt_temp) & call endrun(sub//": ERROR: clubb_detphase_lowtemp must be less than 268.15 K") @@ -1274,6 +1309,7 @@ subroutine clubb_readnl(nlfile) clubb_ipdf_call_placement, & ! In clubb_penta_solve_method, & ! In clubb_tridiag_solve_method, & ! In + clubb_saturation_equation, & ! In clubb_l_use_precip_frac, & ! In clubb_l_predict_upwp_vpwp, & ! In clubb_l_min_wp2_from_corr_wx, & ! In @@ -1328,6 +1364,7 @@ subroutine clubb_readnl(nlfile) clubb_l_mono_flux_lim_um, & ! In clubb_l_mono_flux_lim_vm, & ! In clubb_l_mono_flux_lim_spikefix, & ! In + clubb_l_host_applies_sfc_fluxes, & ! In clubb_config_flags ) ! Out #endif @@ -1373,7 +1410,8 @@ subroutine clubb_ini_cam(pbuf2d) use clubb_api_module, only: & print_clubb_config_flags_api, & - setup_clubb_core_api, & + setup_parameters_model_api, & + check_clubb_settings_api, & init_pdf_params_api, & time_precision, & core_rknd, & @@ -1384,19 +1422,13 @@ subroutine clubb_ini_cam(pbuf2d) read_parameters_api, & w_tol_sqd, & rt_tol, & - thl_tol - - ! These are only needed if we're using a passive scalar - use clubb_api_module, only: & - iisclr_rt, & - iisclr_thl, & - iisclr_CO2, & - iiedsclr_rt, & - iiedsclr_thl, & - iiedsclr_CO2 + thl_tol, & + saturation_bolton, & ! Constant for Bolton approximations of saturation + saturation_gfdl, & ! Constant for the GFDL approximation of saturation + saturation_flatau, & ! Constant for Flatau approximations of saturation + saturation_lookup ! Use a lookup table for mixing length use time_manager, only: is_first_step - use clubb_api_module, only: hydromet_dim use constituents, only: cnst_get_ind use phys_control, only: phys_getopts use spmd_utils, only: iam @@ -1552,13 +1584,13 @@ subroutine clubb_ini_cam(pbuf2d) npccn_idx = pbuf_get_index('NPCCN') - iisclr_rt = -1 - iisclr_thl = -1 - iisclr_CO2 = -1 + sclr_idx%iisclr_rt = -1 + sclr_idx%iisclr_thl = -1 + sclr_idx%iisclr_CO2 = -1 - iiedsclr_rt = -1 - iiedsclr_thl = -1 - iiedsclr_CO2 = -1 + sclr_idx%iiedsclr_rt = -1 + sclr_idx%iiedsclr_thl = -1 + sclr_idx%iiedsclr_CO2 = -1 ! ----------------------------------------------------------------- ! ! Define number of tracers for CLUBB to diffuse @@ -1600,7 +1632,7 @@ subroutine clubb_ini_cam(pbuf2d) Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, & wpxp_Ri_exp, a3_coef_min, a_const, bv_efold, z_displace ) - call read_parameters_api( -99, "", & + call read_parameters_api( 1, -99, "", & C1, C1b, C1c, C2rt, C2thl, C2rtthl, & C4, C_uu_shr, C_uu_buoy, C6rt, C6rtb, C6rtc, & C6thl, C6thlb, C6thlc, C7, C7b, C7c, C8, C8b, C10, & @@ -1625,75 +1657,83 @@ subroutine clubb_ini_cam(pbuf2d) C_invrs_tau_wpxp_Ri, C_invrs_tau_wpxp_N2_thresh, & Cx_min, Cx_max, Richardson_num_min, Richardson_num_max, & wpxp_Ri_exp, a3_coef_min, a_const, bv_efold, z_displace, & - clubb_params ) - - clubb_params(iC2rtthl) = clubb_C2rtthl - clubb_params(iC8) = clubb_C8 - clubb_params(iC11) = clubb_c11 - clubb_params(iC11b) = clubb_c11b - clubb_params(iC14) = clubb_c14 - clubb_params(iC_wp3_pr_turb) = clubb_C_wp3_pr_turb - clubb_params(ic_K10) = clubb_c_K10 - clubb_params(imult_coef) = clubb_mult_coef - clubb_params(iSkw_denom_coef) = clubb_Skw_denom_coef - clubb_params(iC2rt) = clubb_C2rt - clubb_params(iC2thl) = clubb_C2thl - clubb_params(ibeta) = clubb_beta - clubb_params(iC6rt) = clubb_c6rt - clubb_params(iC6rtb) = clubb_c6rtb - clubb_params(iC6rtc) = clubb_c6rtc - clubb_params(iC6thl) = clubb_c6thl - clubb_params(iC6thlb) = clubb_c6thlb - clubb_params(iC6thlc) = clubb_c6thlc - clubb_params(iwpxp_L_thresh) = clubb_wpxp_L_thresh - clubb_params(iC7) = clubb_C7 - clubb_params(iC7b) = clubb_C7b - clubb_params(igamma_coef) = clubb_gamma_coef - clubb_params(ic_K10h) = clubb_c_K10h - clubb_params(ilambda0_stability_coef) = clubb_lambda0_stability_coef - clubb_params(ilmin_coef) = clubb_lmin_coef - clubb_params(iC8b) = clubb_C8b - clubb_params(iskw_max_mag) = clubb_skw_max_mag - clubb_params(iC1) = clubb_C1 - clubb_params(iC1b) = clubb_C1b - clubb_params(igamma_coefb) = clubb_gamma_coefb - clubb_params(iup2_sfc_coef) = clubb_up2_sfc_coef - clubb_params(iC4) = clubb_C4 - clubb_params(iC_uu_shr) = clubb_C_uu_shr - clubb_params(iC_uu_buoy) = clubb_C_uu_buoy - clubb_params(ic_K1) = clubb_c_K1 - clubb_params(ic_K2) = clubb_c_K2 - clubb_params(inu2) = clubb_nu2 - clubb_params(ic_K8) = clubb_c_K8 - clubb_params(ic_K9) = clubb_c_K9 - clubb_params(inu9) = clubb_nu9 - clubb_params(iC_wp2_splat) = clubb_C_wp2_splat - clubb_params(iC_invrs_tau_bkgnd) = clubb_C_invrs_tau_bkgnd - clubb_params(iC_invrs_tau_sfc) = clubb_C_invrs_tau_sfc - clubb_params(iC_invrs_tau_shear) = clubb_C_invrs_tau_shear - clubb_params(iC_invrs_tau_N2) = clubb_C_invrs_tau_N2 - clubb_params(iC_invrs_tau_N2_wp2) = clubb_C_invrs_tau_N2_wp2 - clubb_params(iC_invrs_tau_N2_xp2) = clubb_C_invrs_tau_N2_xp2 - clubb_params(iC_invrs_tau_N2_wpxp) = clubb_C_invrs_tau_N2_wpxp - clubb_params(iC_invrs_tau_N2_clear_wp3) = clubb_C_invrs_tau_N2_clear_wp3 - clubb_params(ibv_efold) = clubb_bv_efold - clubb_params(iwpxp_Ri_exp) = clubb_wpxp_Ri_exp - clubb_params(iz_displace) = clubb_z_displace + clubb_params_single_col ) + + clubb_params_single_col(iC2rtthl) = clubb_C2rtthl + clubb_params_single_col(iC8) = clubb_C8 + clubb_params_single_col(iC11) = clubb_c11 + clubb_params_single_col(iC11b) = clubb_c11b + clubb_params_single_col(iC14) = clubb_c14 + clubb_params_single_col(iC_wp3_pr_turb) = clubb_C_wp3_pr_turb + clubb_params_single_col(ic_K10) = clubb_c_K10 + clubb_params_single_col(imult_coef) = clubb_mult_coef + clubb_params_single_col(iSkw_denom_coef) = clubb_Skw_denom_coef + clubb_params_single_col(iC2rt) = clubb_C2rt + clubb_params_single_col(iC2thl) = clubb_C2thl + clubb_params_single_col(ibeta) = clubb_beta + clubb_params_single_col(iC6rt) = clubb_c6rt + clubb_params_single_col(iC6rtb) = clubb_c6rtb + clubb_params_single_col(iC6rtc) = clubb_c6rtc + clubb_params_single_col(iC6thl) = clubb_c6thl + clubb_params_single_col(iC6thlb) = clubb_c6thlb + clubb_params_single_col(iC6thlc) = clubb_c6thlc + clubb_params_single_col(iwpxp_L_thresh) = clubb_wpxp_L_thresh + clubb_params_single_col(iC7) = clubb_C7 + clubb_params_single_col(iC7b) = clubb_C7b + clubb_params_single_col(igamma_coef) = clubb_gamma_coef + clubb_params_single_col(ic_K10h) = clubb_c_K10h + clubb_params_single_col(ilambda0_stability_coef) = clubb_lambda0_stability_coef + clubb_params_single_col(ilmin_coef) = clubb_lmin_coef + clubb_params_single_col(iC8b) = clubb_C8b + clubb_params_single_col(iskw_max_mag) = clubb_skw_max_mag + clubb_params_single_col(iC1) = clubb_C1 + clubb_params_single_col(iC1b) = clubb_C1b + clubb_params_single_col(igamma_coefb) = clubb_gamma_coefb + clubb_params_single_col(iup2_sfc_coef) = clubb_up2_sfc_coef + clubb_params_single_col(iC4) = clubb_C4 + clubb_params_single_col(iC_uu_shr) = clubb_C_uu_shr + clubb_params_single_col(iC_uu_buoy) = clubb_C_uu_buoy + clubb_params_single_col(ic_K1) = clubb_c_K1 + clubb_params_single_col(ic_K2) = clubb_c_K2 + clubb_params_single_col(inu2) = clubb_nu2 + clubb_params_single_col(ic_K8) = clubb_c_K8 + clubb_params_single_col(ic_K9) = clubb_c_K9 + clubb_params_single_col(inu9) = clubb_nu9 + clubb_params_single_col(iC_wp2_splat) = clubb_C_wp2_splat + clubb_params_single_col(iC_invrs_tau_bkgnd) = clubb_C_invrs_tau_bkgnd + clubb_params_single_col(iC_invrs_tau_sfc) = clubb_C_invrs_tau_sfc + clubb_params_single_col(iC_invrs_tau_shear) = clubb_C_invrs_tau_shear + clubb_params_single_col(iC_invrs_tau_N2) = clubb_C_invrs_tau_N2 + clubb_params_single_col(iC_invrs_tau_N2_wp2) = clubb_C_invrs_tau_N2_wp2 + clubb_params_single_col(iC_invrs_tau_N2_xp2) = clubb_C_invrs_tau_N2_xp2 + clubb_params_single_col(iC_invrs_tau_N2_wpxp) = clubb_C_invrs_tau_N2_wpxp + clubb_params_single_col(iC_invrs_tau_N2_clear_wp3) = clubb_C_invrs_tau_N2_clear_wp3 + clubb_params_single_col(ibv_efold) = clubb_bv_efold + clubb_params_single_col(iwpxp_Ri_exp) = clubb_wpxp_Ri_exp + clubb_params_single_col(iz_displace) = clubb_z_displace + + + ! Override clubb default + if ( trim(subcol_scheme) == 'SILHS' ) then + clubb_config_flags%saturation_formula = saturation_flatau + else + clubb_config_flags%saturation_formula = saturation_gfdl ! Goff & Gratch (1946) approximation for SVP + end if + + + ! Define model constant parameters + call setup_parameters_model_api( theta0, ts_nudge, clubb_params_single_col(iSkw_max_mag) ) ! Set up CLUBB core. Note that some of these inputs are overwritten ! when clubb_tend_cam is called. The reason is that heights can change ! at each time step, which is why dummy arrays are read in here for heights ! as they are immediately overwrote. !$OMP PARALLEL - call setup_clubb_core_api( & - nlev+1, theta0, ts_nudge, & ! In - hydromet_dim, sclr_dim, & ! In - sclr_tol, edsclr_dim, clubb_params, & ! In - l_host_applies_sfc_fluxes, & ! In - saturation_equation, & ! In - l_input_fields, & ! In - clubb_config_flags, & ! In - err_code ) ! Out + call check_clubb_settings_api( nlev+1, clubb_params_single_col, & ! Intent(in) + l_implemented, & ! Intent(in) + l_input_fields, & ! Intent(in) + clubb_config_flags, & ! intent(in) + err_code ) ! Intent(out) if ( err_code == clubb_fatal_error ) then call endrun('clubb_ini_cam: FATAL ERROR CALLING SETUP_CLUBB_CORE') @@ -1703,7 +1743,7 @@ subroutine clubb_ini_cam(pbuf2d) ! Print the list of CLUBB parameters if ( masterproc ) then do j = 1, nparams, 1 - write(iulog,*) params_list(j), " = ", clubb_params(j) + write(iulog,*) params_list(j), " = ", clubb_params_single_col(j) enddo endif @@ -1810,18 +1850,25 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'W/m2' , 'qt flux (EDMF)' ) end if +#ifndef SILHS + ! hm_metadata is set up by calling init_pdf_hydromet_arrays_api in subcol_init_SILHS. + ! So if we are not using silhs, we allocate the parts of hm_metadata that need allocating + ! in order to making intel debug tests happy. + allocate( hm_metadata%hydromet_list(1) ) + allocate( hm_metadata%l_mix_rat_hm(1) ) +#endif + ! Initialize statistics, below are dummy variables dum1 = 300._r8 dum2 = 1200._r8 dum3 = 300._r8 - if (stats_metadata%l_stats) then - - call stats_init_clubb( .true., dum1, dum2, & - nlev+1, nlev+1, nlev+1, dum3, & - stats_zt(:), stats_zm(:), stats_sfc(:), & - stats_rad_zt(:), stats_rad_zm(:)) + + call stats_init_clubb( .true., dum1, dum2, & + nlev+1, nlev+1, nlev+1, dum3, & + stats_zt(:), stats_zm(:), stats_sfc(:), & + stats_rad_zt(:), stats_rad_zm(:)) allocate(out_zt(pcols,pverp,stats_zt(1)%num_output_fields), stat=ierr) if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate out_zt' ) @@ -2046,7 +2093,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rt_tol, & thl_tol, & stats_begin_timestep_api, & - hydromet_dim, calculate_thlp2_rad_api, update_xp2_mc_api, & + calculate_thlp2_rad_api, update_xp2_mc_api, & sat_mixrat_liq_api, & fstderr, & ipdf_post_advance_fields, & @@ -2255,7 +2302,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & wp2up2_inout, & ! w'^2 u'^2 (momentum levels) wp2vp2_inout, & ! w'^2 v'^2 (momentum levels) zt_g, & ! Thermodynamic grid of CLUBB [m] - zi_g ! Momentum grid of CLUBB [m] + zi_g ! Momentum grid of CLUBB [m] ! Local CLUBB variables dimensioned as NCOL (only useful columns) to be sent into the clubb run api ! NOTE: THESE VARIABLS SHOULD NOT BE USED IN PBUF OR OUTFLD (HISTORY) SUBROUTINES @@ -2495,6 +2542,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & type(nu_vertical_res_dep) :: nu_vert_res_dep ! Vertical resolution dependent nu values real(r8) :: lmin + real(r8), dimension(state%ncol,nparams) :: & + clubb_params ! Adjustable CLUBB parameters (C1, C2 ...) + #endif det_s(:) = 0.0_r8 det_ice(:) = 0.0_r8 @@ -3046,6 +3096,10 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & zi_g, zt_g, & ! intent(in) gr ) ! intent(out) + do i = 1, ncol + clubb_params(i,:) = clubb_params_single_col(:) + end do + call setup_parameters_api( zi_g(:,2), clubb_params, gr, ncol, grid_type, & ! intent(in) clubb_config_flags%l_prescribed_avg_deltaz, & ! intent(in) lmin, nu_vert_res_dep, err_code ) ! intent(out) @@ -3399,7 +3453,9 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & ! Advance CLUBB CORE one timestep in the future call advance_clubb_core_api( gr, pverp+1-top_lev, ncol, & - l_implemented, dtime, fcor, sfc_elevation, hydromet_dim, & + l_implemented, dtime, fcor, sfc_elevation, & + hydromet_dim, & + sclr_dim, sclr_tol, edsclr_dim, sclr_idx, & thlm_forcing, rtm_forcing, um_forcing, vm_forcing, & sclrm_forcing, edsclrm_forcing, wprtp_forcing, & wpthlp_forcing, rtp2_forcing, thlp2_forcing, & @@ -3410,7 +3466,8 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtm_ref, thlm_ref, um_ref, vm_ref, ug, vg, & p_in_Pa, rho_zm, rho_zt, exner, & rho_ds_zm, rho_ds_zt, invrs_rho_ds_zm, & - invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, hydromet, & + invrs_rho_ds_zt, thv_ds_zm, thv_ds_zt, & + hydromet, hm_metadata%l_mix_rat_hm, & rfrzm, radf, & wphydrometp, wp2hmp, rtphmp_zt, thlphmp_zt, & grid_dx, grid_dy, & @@ -3491,7 +3548,7 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & thlp2_rad_out(:,:) = 0._r8 do i=1, ncol - call calculate_thlp2_rad_api(nlev+1, rcm_out_zm(i,:), thlprcp_out(i,:), qrl_zm(i,:), clubb_params, & + call calculate_thlp2_rad_api(nlev+1, rcm_out_zm(i,:), thlprcp_out(i,:), qrl_zm(i,:), clubb_params(i,:), & thlp2_rad_out(i,:)) end do @@ -3792,22 +3849,22 @@ subroutine clubb_tend_cam( state, ptend_all, pbuf, hdtime, & rtm_integral_ltend(:) = 0._r8 do k=1, pver - do i=1, ncol + do i=1, ncol - ptend_loc%u(i,k) = (um(i,k) - state1%u(i,k)) / hdtime ! east-west wind - ptend_loc%v(i,k) = (vm(i,k) - state1%v(i,k)) / hdtime ! north-south wind - ptend_loc%q(i,k,ixq) = (rtm(i,k) - rcm(i,k)-state1%q(i,k,ixq)) / hdtime ! water vapor - ptend_loc%q(i,k,ixcldliq) = (rcm(i,k) - state1%q(i,k,ixcldliq)) / hdtime ! Tendency of liquid water - ptend_loc%s(i,k) = (clubb_s(i,k) - state1%s(i,k)) / hdtime ! Tendency of static energy + ptend_loc%u(i,k) = (um(i,k) - state1%u(i,k)) / hdtime ! east-west wind + ptend_loc%v(i,k) = (vm(i,k) - state1%v(i,k)) / hdtime ! north-south wind + ptend_loc%q(i,k,ixq) = (rtm(i,k) - rcm(i,k)-state1%q(i,k,ixq)) / hdtime ! water vapor + ptend_loc%q(i,k,ixcldliq) = (rcm(i,k) - state1%q(i,k,ixcldliq)) / hdtime ! Tendency of liquid water + ptend_loc%s(i,k) = (clubb_s(i,k) - state1%s(i,k)) / hdtime ! Tendency of static energy - rtm_integral_ltend(i) = rtm_integral_ltend(i) + ptend_loc%q(i,k,ixcldliq)*state1%pdel(i,k) - rtm_integral_vtend(i) = rtm_integral_vtend(i) + ptend_loc%q(i,k,ixq)*state1%pdel(i,k) + rtm_integral_ltend(i) = rtm_integral_ltend(i) + ptend_loc%q(i,k,ixcldliq)*state1%pdel(i,k) + rtm_integral_vtend(i) = rtm_integral_vtend(i) + ptend_loc%q(i,k,ixq)*state1%pdel(i,k) - end do - end do + end do + end do - rtm_integral_ltend(:) = rtm_integral_ltend(:)/gravit - rtm_integral_vtend(:) = rtm_integral_vtend(:)/gravit + rtm_integral_ltend(:) = rtm_integral_ltend(:)/gravit + rtm_integral_vtend(:) = rtm_integral_vtend(:)/gravit if (clubb_do_adv) then if (macmic_it == cld_macmic_num_steps) then @@ -4691,7 +4748,7 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Set stats_variables variables with inputs from calling subroutine stats_metadata%l_stats = l_stats_in - + stats_metadata%stats_tsamp = stats_tsamp_in stats_metadata%stats_tout = stats_tout_in @@ -4795,7 +4852,9 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & if( ierr /= 0 ) call endrun("stats_init_clubb: Failed to allocate stats_zt%file%z") ! Default initialization for array indices for zt - call stats_init_zt_api( clubb_vars_zt, & + call stats_init_zt_api( hydromet_dim, sclr_dim, edsclr_dim, & + hm_metadata%hydromet_list, hm_metadata%l_mix_rat_hm, & + clubb_vars_zt, & l_error, & stats_metadata, stats_zt(j) ) @@ -4832,7 +4891,9 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & allocate( stats_zm(j)%file%grid_avg_var( stats_zm(j)%num_output_fields ) ) allocate( stats_zm(j)%file%z( stats_zm(j)%kk ) ) - call stats_init_zm_api( clubb_vars_zm, & + call stats_init_zm_api( hydromet_dim, sclr_dim, edsclr_dim, & + hm_metadata%hydromet_list, hm_metadata%l_mix_rat_hm, & + clubb_vars_zm, & l_error, & stats_metadata, stats_zm(j) ) @@ -4916,7 +4977,6 @@ subroutine stats_init_clubb( l_stats_in, stats_tsamp_in, stats_tout_in, & ! Initialize sfc (surface point) - i = 1 do while ( ichar(clubb_vars_sfc(i)(1:1)) /= 0 .and. & len_trim(clubb_vars_sfc(i)) /= 0 .and. & diff --git a/src/physics/cam/subcol_SILHS.F90 b/src/physics/cam/subcol_SILHS.F90 index e941889e50..af039a254a 100644 --- a/src/physics/cam/subcol_SILHS.F90 +++ b/src/physics/cam/subcol_SILHS.F90 @@ -19,16 +19,20 @@ module subcol_SILHS #ifdef SILHS use clubb_intr, only: & clubb_config_flags, & - clubb_params, & + clubb_params_single_col, & stats_metadata, & stats_zt, stats_zm, stats_sfc, & - pdf_params_chnk + pdf_params_chnk, & + hm_metadata, & + hydromet_dim, & + pdf_dim use clubb_api_module, only: & hmp2_ip_on_hmm2_ip_slope_type, & hmp2_ip_on_hmm2_ip_intrcpt_type, & precipitation_fractions, & - stats + stats, & + core_rknd use silhs_api_module, only: & silhs_config_flags_type @@ -59,6 +63,11 @@ module subcol_SILHS type (stats), target :: stats_lh_zt, & stats_lh_sfc !$omp threadprivate(stats_lh_zt, stats_lh_sfc) + + real( kind = core_rknd ), dimension(:,:), allocatable :: & + corr_array_n_cloud, & + corr_array_n_below + #endif !----- @@ -334,10 +343,8 @@ subroutine subcol_init_SILHS(pbuf2d) #ifdef CLUBB_SGS #ifdef SILHS use clubb_api_module, only: core_rknd, & - pdf_dim, & setup_corr_varnce_array_api, & init_pdf_hydromet_arrays_api, & - Ncnp2_on_Ncnm2, & set_clubb_debug_level_api #endif @@ -357,7 +364,6 @@ subroutine subcol_init_SILHS(pbuf2d) ! To set up CLUBB hydromet indices integer :: & - hydromet_dim, & ! Number of enabled hydrometeors iirr, & ! Hydrometeor array index for rain water mixing ratio, rr iirs, & ! Hydrometeor array index for snow mixing ratio, rs iiri, & ! Hydrometeor array index for ice mixing ratio, ri @@ -446,36 +452,38 @@ subroutine subcol_init_SILHS(pbuf2d) !------------------------------- iirr = 1 iirs = 3 - iiri = 5 + iiri = 5 iirg = -1 - iiNr = 2 + iiNr = 2 iiNs = 4 - iiNi = 6 + iiNi = 6 iiNg = -1 hydromet_dim = 6 - ! Set up pdf indices, hydromet indicies, hydromet arrays, and hydromet variance ratios - call init_pdf_hydromet_arrays_api( 1.0_core_rknd, 1.0_core_rknd, & ! intent(in) - hydromet_dim, & ! intent(in) - iirr, iiri, iirs, iirg, & ! intent(in) - iiNr, iiNi, iiNs, iiNg, & ! intent(in) - subcol_SILHS_hmp2_ip_on_hmm2_ip_slope, & ! optional(in) - subcol_SILHS_hmp2_ip_on_hmm2_ip_intrcpt ) ! optional(in) - - Ncnp2_on_Ncnm2 = subcol_SILHS_ncnp2_on_ncnm2 + call init_pdf_hydromet_arrays_api( 1.0_core_rknd, 1.0_core_rknd, hydromet_dim, & ! intent(in) + iirr, iiNr, iiri, iiNi, & ! intent(in) + iirs, iiNs, iirg, iiNg, & ! intent(in) + subcol_SILHS_ncnp2_on_ncnm2, & ! intent(in) + hm_metadata, pdf_dim, & ! intent(out) + subcol_SILHS_hmp2_ip_on_hmm2_ip_slope, & ! optional(in) + subcol_SILHS_hmp2_ip_on_hmm2_ip_intrcpt ) ! optional(in) !------------------------------- ! Set up hydrometeors and correlation arrays for SILHS !------------------------------- + allocate(corr_array_n_cloud(pdf_dim,pdf_dim)) + allocate(corr_array_n_below(pdf_dim,pdf_dim)) + corr_file_path_cloud = trim( subcol_SILHS_corr_file_path )//trim( subcol_SILHS_corr_file_name )//cloud_file_ext corr_file_path_below = trim( subcol_SILHS_corr_file_path )//trim( subcol_SILHS_corr_file_name )//below_file_ext call setup_corr_varnce_array_api( corr_file_path_cloud, corr_file_path_below, & - newunit(iunit), & - clubb_config_flags%l_fix_w_chi_eta_correlations ) + pdf_dim, hm_metadata, newunit(iunit), & + clubb_config_flags%l_fix_w_chi_eta_correlations, & ! In + corr_array_n_cloud, corr_array_n_below ) !------------------------------- ! Register output fields from SILHS @@ -600,31 +608,15 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) #ifdef CLUBB_SGS #ifdef SILHS - use clubb_api_module, only : hydromet_dim, & - - setup_pdf_parameters_api, & - - hydromet_pdf_parameter, & + use clubb_api_module, only : setup_pdf_parameters_api, & zm2zt_api, setup_grid_heights_api, & - iirr, iiNr, iirs, iiri, & - iirg, iiNs, & - iiNi, iiNg, & - core_rknd, & w_tol_sqd, zero_threshold, & em_min, cloud_frac_min, & ! rc_tol, & - pdf_dim, & - corr_array_n_cloud, & - corr_array_n_below, & - iiPDF_chi, iiPDF_rr, & - iiPDF_w, iiPDF_Nr, & - iiPDF_ri, iiPDF_Ni, & - iiPDF_Ncn, iiPDF_rs, iiPDF_Ns, & - genrand_intg, genrand_init_api, & nparams, ic_K, & @@ -844,6 +836,13 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) type(grid) :: gr type(precipitation_fractions) :: precip_fracs + + ! Used as shortcuts to avoid typing hm_metadata%iiPDF_xx + integer :: & + iiPDF_chi, iiPDF_rr, iiPDF_w, iiPDF_Nr, & + iiPDF_ri, iiPDF_Ni, iiPDF_Ncn, iiPDF_rs, iiPDF_Ns, & + iirr, iiNr, iirs, iiri, & + iirg, iiNs, iiNi, iiNg !------------------------------------------------ ! Begin Code @@ -885,6 +884,26 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) ! does not? ! #ERDBG: The model iteration number is not used in SILHS unless ! sequence_length > 1, but nobody runs with that option. + + ! Copy hm_metadata indices to shortcuts + iiPDF_chi = hm_metadata%iiPDF_chi + iiPDF_Ncn = hm_metadata%iiPDF_Ncn + iiPDF_rr = hm_metadata%iiPDF_rr + iiPDF_w = hm_metadata%iiPDF_w + iiPDF_Nr = hm_metadata%iiPDF_Nr + iiPDF_ri = hm_metadata%iiPDF_ri + iiPDF_Ni = hm_metadata%iiPDF_Ni + iiPDF_rs = hm_metadata%iiPDF_rs + iiPDF_Ns = hm_metadata%iiPDF_Ns + iirr = hm_metadata%iirr + iiNr = hm_metadata%iiNr + iirs = hm_metadata%iirs + iiri = hm_metadata%iiri + iirg = hm_metadata%iirg + iiNs = hm_metadata%iiNs + iiNi = hm_metadata%iiNi + iiNg = hm_metadata%iiNg + !---------------- ! Establish associations between pointers and physics buffer fields !---------------- @@ -902,7 +921,7 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) call pbuf_get_field(pbuf, kvh_idx, khzm_in) ! Pull c_K from clubb parameters. - c_K = clubb_params(ic_K) + c_K = clubb_params_single_col(ic_K) !---------------- ! Copy state and populate numbers and values of sub-columns @@ -1129,27 +1148,28 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) call init_precip_fracs_api( pverp-top_lev+1, ngrdcol, & precip_fracs ) - call setup_pdf_parameters_api( gr, pverp-top_lev+1, ngrdcol, pdf_dim, ztodt, & ! In - Nc_in_cloud, cld_frac_in, khzm, & ! In - ice_supersat_frac_in, hydromet, wphydrometp, & ! In - corr_array_n_cloud, corr_array_n_below, & ! In - pdf_params_chnk(lchnk), & ! In - clubb_params, & ! In - clubb_config_flags%iiPDF_type, & ! In - clubb_config_flags%l_use_precip_frac, & ! In - clubb_config_flags%l_predict_upwp_vpwp, & ! In - clubb_config_flags%l_diagnose_correlations, & ! In - clubb_config_flags%l_calc_w_corr, & ! In - clubb_config_flags%l_const_Nc_in_cloud, & ! In - clubb_config_flags%l_fix_w_chi_eta_correlations, & ! In - stats_metadata, & ! In - stats_zt, stats_zm, stats_sfc, & ! In - hydrometp2, & ! Inout - mu_x_1, mu_x_2, & ! Out - sigma_x_1, sigma_x_2, & ! Out - corr_array_1, corr_array_2, & ! Out - corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Out - precip_fracs ) ! Inout + call setup_pdf_parameters_api( gr, pverp-top_lev+1, ngrdcol, pdf_dim, hydromet_dim, ztodt, & ! In + Nc_in_cloud, cld_frac_in, khzm, & ! In + ice_supersat_frac_in, hydromet, wphydrometp, & ! In + corr_array_n_cloud, corr_array_n_below, & ! In + hm_metadata, & ! In + pdf_params_chnk(lchnk), & ! In + clubb_params_single_col, & ! In + clubb_config_flags%iiPDF_type, & ! In + clubb_config_flags%l_use_precip_frac, & ! In + clubb_config_flags%l_predict_upwp_vpwp, & ! In + clubb_config_flags%l_diagnose_correlations, & ! In + clubb_config_flags%l_calc_w_corr, & ! In + clubb_config_flags%l_const_Nc_in_cloud, & ! In + clubb_config_flags%l_fix_w_chi_eta_correlations, & ! In + stats_metadata, & ! In + stats_zt, stats_zm, stats_sfc, & ! In + hydrometp2, & ! Inout + mu_x_1, mu_x_2, & ! Out + sigma_x_1, sigma_x_2, & ! Out + corr_array_1, corr_array_2, & ! Out + corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! Out + precip_fracs ) ! Inout ! In order for Lscale to be used properly, it needs to be passed out of ! advance_clubb_core, saved to the pbuf, and then pulled out of the @@ -1220,15 +1240,11 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) iter, pdf_dim, num_subcols, sequence_length, pverp-top_lev+1, ngrdcol, & ! In l_calc_weights_all_levs_itime, & ! In pdf_params_chnk(lchnk), delta_zm, Lscale, & ! In - lh_seed, & ! In + lh_seed, hm_metadata, & ! In rho_ds_zt, & ! In mu_x_1, mu_x_2, sigma_x_1, sigma_x_2, & ! In corr_cholesky_mtx_1, corr_cholesky_mtx_2, & ! In precip_fracs, silhs_config_flags, & ! In - clubb_params, & ! In - clubb_config_flags%l_uv_nudge, & ! In - clubb_config_flags%l_tke_aniso, & ! In - clubb_config_flags%l_standard_term_ta, & ! In vert_decorr_coef, & ! In stats_metadata, & ! In stats_lh_zt, stats_lh_sfc, & ! InOut @@ -1236,15 +1252,15 @@ subroutine subcol_gen_SILHS(state, tend, state_sc, tend_sc, pbuf) lh_sample_point_weights) ! Out ! Extract clipped variables from subcolumns - call clip_transform_silhs_output_api( gr, pverp-top_lev+1, ngrdcol, num_subcols, & ! In - pdf_dim, hydromet_dim, & ! In - X_mixt_comp_all_levs, & ! In - X_nl_all_levs, & ! In - pdf_params_chnk(lchnk), & ! In - l_use_Ncn_to_Nc, & ! In - lh_rt_clipped, lh_thl_clipped, & ! Out - lh_rc_clipped, lh_rv_clipped, & ! Out - lh_Nc_clipped ) ! Out + call clip_transform_silhs_output_api( gr, pverp-top_lev+1, ngrdcol, num_subcols, & ! In + pdf_dim, hydromet_dim, hm_metadata, & ! In + X_mixt_comp_all_levs, & ! In + X_nl_all_levs, & ! In + pdf_params_chnk(lchnk), & ! In + l_use_Ncn_to_Nc, & ! In + lh_rt_clipped, lh_thl_clipped, & ! Out + lh_rc_clipped, lh_rv_clipped, & ! Out + lh_Nc_clipped ) ! Out !$acc wait if ( l_est_kessler_microphys ) then From dc472dae1b5fa79fa7f5e8b9fbbcd7e765bf54b2 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Wed, 26 Jun 2024 10:36:47 -0600 Subject: [PATCH 39/75] udpates for supporting GPU testing --- test/system/archive_baseline.sh | 55 ++++++++++----------------------- test/system/test_driver.sh | 6 ++-- 2 files changed, 18 insertions(+), 43 deletions(-) diff --git a/test/system/archive_baseline.sh b/test/system/archive_baseline.sh index 8460923a1f..e457081ba4 100755 --- a/test/system/archive_baseline.sh +++ b/test/system/archive_baseline.sh @@ -12,7 +12,7 @@ cat << EOF1 NAME archive_baseline.sh - archive pretag baselines to set locations on - hobart, izumi and derecho. + izumi and derecho. SYNOPSIS @@ -24,41 +24,28 @@ SYNOPSIS ENVIROMENT VARIABLES CESM_TESTDIR - Directory that contains the CESM finished results you wish to archive. - CAM_FC - Compiler used, only used on hobart and izumi (PGI,NAG), where the compiler + CAM_FC - Compiler used, used on derecho (INTEL, NVHPC) and izumi (GNU,NAG), where the compiler name is appended to the archive directory. BASELINE ARCHIVED LOCATION - hobart, izumi: /fs/cgd/csm/models/atm/cam/pretag_bl/TAGNAME_pgi - /fs/cgd/csm/models/atm/cam/pretag_bl/TAGNAME_nag - derecho: /glade/campaign/cesm/community/amwg/cam_baselines/TAGNAME + izumi: /fs/cgd/csm/models/atm/cam/pretag_bl/TAGNAME_gnu + /fs/cgd/csm/models/atm/cam/pretag_bl/TAGNAME_nag + derecho: /glade/campaign/cesm/community/amwg/cam_baselines/TAGNAME_intel + /glade/campaign/cesm/community/amwg/cam_baselines/TAGNAME_nvhpc HOW TO USE ARCHIVE BASELINES - Set BL_TESTDIR to the archived baseline you wish to load. + on izumi: + env CESM_TESTDIR=/scratch/cluster/YourName/aux_cam_gnu_yyyymmddsssss CAM_FC=GNU ./archive_baseline.sh cam6_4_XXX + env CESM_TESTDIR=/scratch/cluster/YourName/aux_cam_nag_yyyymmddsssss CAM_FC=NAG ./archive_baseline.sh cam6_3_XXX - -WORK FLOW - - This is an example for hobart or izumi. - - Modify your sandbox with the changes you want. - setenv CAM_FC PGI - setenv CAM_TESTDIR /scratch/cluster/fischer/cam5_2_06 - Run the cam test suite. - Make your trunk tag - archive_baseline.sh cam5_2_06 - - Create a new sandbox. - setenv CAM_FC PGI - setenv CAM_TESTDIR /scratch/cluster/fischer/cam5_2_07 - setenv BL_TESTDIR /fs/cgd/csm/models/atm/cam/pretag_bl/cam5_2_06_pgi - Run the cam test suite. - Make your trunk tag - archive_baseline.sh cam5_2_07 + on derecho: + env CESM_TESTDIR=/glade/derecho/scratch/YourName/aux_cam_intel_yyyymmddsssss CAM_FC=INTEL ./archive_baseline.sh cam6_4_XXX + env CESM_TESTDIR=/glade/derecho/scratch/YourName/aux_cam_nvhpc_yyyymmddsssss CAM_FC=NVHPC ./archive_baseline.sh cam6_4_XXX WARNING @@ -73,20 +60,10 @@ fi hostname=`hostname` case $hostname in - ho*) - echo "server: hobart" - if [ -z "$CAM_FC" ]; then - CAM_FC="PGI" - fi - test_file_list="tests_pretag_hobart_${CAM_FC,,}" - cam_tag=$1_${CAM_FC,,} - baselinedir="/fs/cgd/csm/models/atm/cam/pretag_bl/$cam_tag" - ;; - iz*) echo "server: izumi" if [ -z "$CAM_FC" ]; then - CAM_FC="PGI" + echo "Must specify CAM_FC" fi test_file_list="tests_pretag_izumi_${CAM_FC,,}" cam_tag=$1_${CAM_FC,,} @@ -96,9 +73,9 @@ case $hostname in de*) echo "server: derecho" if [ -z "$CAM_FC" ]; then - CAM_FC="INTEL" + echo "Must specify CAM_FC" fi - test_file_list="tests_pretag_derecho" + test_file_list="tests_pretag_derecho_${CAM_FC,,}" cam_tag=$1 baselinedir="/glade/campaign/cesm/community/amwg/cam_baselines/$cam_tag" ;; @@ -130,7 +107,7 @@ fi case $hostname in - ch* | hobart | izumi) + de* | izumi) if [ -z "$CESM_TESTDIR" ]; then echo '***********************************************************************************' echo 'INFO: The aux_cam and test_cam tests were NOT archived' diff --git a/test/system/test_driver.sh b/test/system/test_driver.sh index 80a632b14f..e787d25386 100755 --- a/test/system/test_driver.sh +++ b/test/system/test_driver.sh @@ -466,6 +466,8 @@ if [ "${hostname:0:6}" == "casper" ] || [ "${hostname:0:5}" == "crhtc" ]; then fi if [ -n "${CAM_FC}" ]; then comp="_${CAM_FC,,}" +else + echo "ERROR: Must specify CAM_FC" fi if [ "${cesm_test_suite}" != "none" -a -n "${cesm_test_mach}" ]; then @@ -547,8 +549,6 @@ if [ "${cesm_test_suite}" != "none" -a -n "${cesm_test_mach}" ]; then if [ -n "${CAM_FC}" ]; then testargs="${testargs} --xml-compiler ${CAM_FC,,}" - else - testargs="${testargs} --xml-compiler intel" fi case $hostname in # derecho @@ -586,8 +586,6 @@ if [ "${cesm_test_suite}" != "none" -a -n "${cesm_test_mach}" ]; then cmd="query_testlists --xml-category $cesm_test --xml-machine ${cesm_test_mach}" if [ -n "${CAM_FC}" ]; then cmd="${cmd} --xml-compiler ${CAM_FC,,}" - else - cmd="${cmd} --xml-compiler intel" fi cmd="${CIME_ROOT}/scripts/"$cmd cime_testlist=`$cmd` From 9cf174c85d9a32c57d4aeafeaf81cc188c0e7da1 Mon Sep 17 00:00:00 2001 From: Katetc Date: Thu, 27 Jun 2024 11:38:41 -0600 Subject: [PATCH 40/75] Updating clubb submodule --- src/physics/clubb | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/physics/clubb b/src/physics/clubb index 50cee042e5..4b3e80faef 160000 --- a/src/physics/clubb +++ b/src/physics/clubb @@ -1 +1 @@ -Subproject commit 50cee042e588fefd3fe58c2a1d638affec8c0389 +Subproject commit 4b3e80faefdbbe79cda650a8401364ec640e05e7 From 6244ced56660b6f41816137572921df4f1331d3b Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Mon, 8 Jul 2024 10:22:23 -0600 Subject: [PATCH 41/75] remove bfb line for testing --- src/dynamics/eul/iop.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/dynamics/eul/iop.F90 b/src/dynamics/eul/iop.F90 index 245fbc4673..0754030830 100644 --- a/src/dynamics/eul/iop.F90 +++ b/src/dynamics/eul/iop.F90 @@ -126,8 +126,6 @@ subroutine iop_update_prognostics(timelevel,ps,t3,u3,v3,q3) if (present(ps)) ps(1,1,timelevel) = psobs if (present(t3)) t3(1,ioptop:,1,timelevel) = tobs(ioptop:) if (present(q3)) q3(1,ioptop:,1,1,timelevel) = qobs(ioptop:) -!!!!!jt revert next line only for bfb - ioptop=1 if (present(u3)) u3(1,ioptop:,1,timelevel) = uobs(ioptop:) if (present(v3)) v3(1,ioptop:,1,timelevel) = vobs(ioptop:) From 88d8c3a59fd56dbf3269d9a4c6d6221f1eead0f4 Mon Sep 17 00:00:00 2001 From: Katetc Date: Tue, 9 Jul 2024 16:41:27 -0600 Subject: [PATCH 42/75] Update atmos_phys submodule for some reason --- src/atmos_phys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/atmos_phys b/src/atmos_phys index 4944547f04..f4c09618ea 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 4944547f04b1457d78bf7d3c0becddcfe0deabb9 +Subproject commit f4c09618eaaa19eaf3382f0473a531e20aa9f808 From b3c74ce4497ad394c052a834befc3a6c0c57fbb4 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 11 Jul 2024 10:12:06 -0600 Subject: [PATCH 43/75] update cam to match atmos_phys changes in dadadj (return heating rate in ptend%s) --- src/atmos_phys | 2 +- src/physics/cam/dadadj_cam.F90 | 8 +++----- 2 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/atmos_phys b/src/atmos_phys index 4c0f72356a..c98d6acaab 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 4c0f72356afa6c5453b4b21a9fb041b3a3ac155c +Subproject commit c98d6acaab123519b933e6cbc3233aaccc66af7e diff --git a/src/physics/cam/dadadj_cam.F90 b/src/physics/cam/dadadj_cam.F90 index 2a7e09014e..c2a6d685d1 100644 --- a/src/physics/cam/dadadj_cam.F90 +++ b/src/physics/cam/dadadj_cam.F90 @@ -129,8 +129,9 @@ subroutine dadadj_tend(dt, state, ptend) ! dadadj_run returns t tend, we are passing the ptend%s array to receive the t tendency and will convert it to s ! before it is returned to CAM.. call dadadj_run( & - ncol, dt, state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), state%t(:ncol,:), state%q(:ncol,:,1), cappav(:ncol,:,lchnk), & - ptend%s(:ncol,:), ptend%q(:ncol,:,1), dadpdf(:ncol,:), scheme_name, errmsg, errflg) + ncol, pver, dt, state%pmid(:ncol,:), state%pint(:ncol,:), state%pdel(:ncol,:), & + state%t(:ncol,:), state%q(:ncol,:,1), cappav(:ncol,:,lchnk), cpairv(:ncol,:,lchnk), ptend%s(:ncol,:), & + ptend%q(:ncol,:,1), dadpdf(:ncol,:), scheme_name, errmsg, errflg) ! error exit if (errflg /= 0) then @@ -146,9 +147,6 @@ subroutine dadadj_tend(dt, state, ptend) call outfld('DADADJ_PD', dadpdf(:ncol,:), ncol, lchnk) - ! convert the t tendency to an s tendency for cam - ptend%s(:ncol,:) = ptend%s(:ncol,:) * cpairv(:ncol,:,lchnk) - end subroutine dadadj_tend !=============================================================================== From ed9a91cc332958363c37a242e0048ff5832a382c Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Fri, 12 Jul 2024 08:57:12 -0600 Subject: [PATCH 44/75] Add GPU tests on derecho --- cime_config/testdefs/testlist_cam.xml | 2 ++ test/system/test_driver.sh | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 9f259ac673..f79abffd88 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1483,6 +1483,7 @@ + @@ -1491,6 +1492,7 @@ + diff --git a/test/system/test_driver.sh b/test/system/test_driver.sh index e787d25386..ef86e43cb8 100755 --- a/test/system/test_driver.sh +++ b/test/system/test_driver.sh @@ -1,4 +1,4 @@ -#!/bin/sh +!/bin/sh # # test_driver.sh: driver for the testing of CAM with standalone scripts # @@ -468,6 +468,7 @@ if [ -n "${CAM_FC}" ]; then comp="_${CAM_FC,,}" else echo "ERROR: Must specify CAM_FC" + exit 1 fi if [ "${cesm_test_suite}" != "none" -a -n "${cesm_test_mach}" ]; then From e8bb66947859fff2b757b5e98bb957cd4f7c687b Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 19 Jul 2024 08:26:19 -0600 Subject: [PATCH 45/75] add src/atmos_phys --- src/atmos_phys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/atmos_phys b/src/atmos_phys index c98d6acaab..1e70ee7aa0 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit c98d6acaab123519b933e6cbc3233aaccc66af7e +Subproject commit 1e70ee7aa09a08a6c1375c9077118662d174b5ae From 7a83d6b7b9ba92c70fc3bb702dff56bb41888ea7 Mon Sep 17 00:00:00 2001 From: Francis Vitt Date: Tue, 23 Jul 2024 17:52:43 -0600 Subject: [PATCH 46/75] dz fix in convproc modified: src/chemistry/modal_aero/modal_aero_convproc.F90 --- src/chemistry/modal_aero/modal_aero_convproc.F90 | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/chemistry/modal_aero/modal_aero_convproc.F90 b/src/chemistry/modal_aero/modal_aero_convproc.F90 index a22f750f21..9def684ec0 100644 --- a/src/chemistry/modal_aero/modal_aero_convproc.F90 +++ b/src/chemistry/modal_aero/modal_aero_convproc.F90 @@ -1098,8 +1098,6 @@ subroutine ma_convproc_tend( & real(r8) tmpmata(pcnst_extd,3) ! work variables real(r8) xinv_ntsub ! 1.0/ntsub real(r8) wup(pver) ! working updraft velocity (m/s) - real(r8) zmagl(pver) ! working height above surface (m) - real(r8) zkm ! working height above surface (km) real(r8) :: dcondt2(pcols,pver,pcnst_extd) real(r8) :: conu2(pcols,pver,pcnst_extd) @@ -1293,16 +1291,6 @@ subroutine ma_convproc_tend( & dtsub = dt*xinv_ntsub courantmax = courantmax*xinv_ntsub -! zmagl(k) = height above surface for middle of level k - zmagl(pver) = 0.0_r8 - do k = pver, 1, -1 - if (k < pver) then - zmagl(k) = zmagl(k+1) + 0.5_r8*dz - end if - dz = dp_i(k)*hund_ovr_g/rhoair_i(k) - zmagl(k) = zmagl(k) + 0.5_r8*dz - end do - ! load tracer mixing ratio array, which will be updated at the end of each jtsub interation q_i(1:pver,1:pcnst) = q(icol,1:pver,1:pcnst) @@ -1448,6 +1436,7 @@ subroutine ma_convproc_tend( & ! compute lagrangian transport time (dt_u) and updraft fractional area (fa_u) ! *** these must obey dt_u(k)*mu_p_eudp(k) = dp_i(k)*fa_u(k) + dz = dp_i(k)*hund_ovr_g/rhoair_i(k) dt_u(k) = dz/wup(k) dt_u(k) = min( dt_u(k), dt ) fa_u(k) = dt_u(k)*(mu_p_eudp(k)/dp_i(k)) @@ -2324,6 +2313,7 @@ subroutine accumulate_to_larger_mode( spc_name, lptr, prevap ) integer :: m,n, nl,ns + nl = -1 ! find constituent index of the largest mode for the species loop1: do m = 1,ntot_amode-1 nl = lptr(mode_size_order(m)) From 31e33fe758eee65f524a7a23cc243331b20e561b Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 25 Jul 2024 14:33:21 -0600 Subject: [PATCH 47/75] remove variable initialization, not necessary for bfb --- components/cice | 2 +- components/cmeps | 2 +- src/dynamics/fv3 | 2 +- src/physics/cam/physpkg.F90 | 48 +++++++++++++++++--------------- src/physics/cam7/physpkg.F90 | 54 +++++++++++++++++++----------------- 5 files changed, 58 insertions(+), 50 deletions(-) diff --git a/components/cice b/components/cice index bdf6ea04d6..b56154b318 160000 --- a/components/cice +++ b/components/cice @@ -1 +1 @@ -Subproject commit bdf6ea04d6133434fcaa4de5336de106f01290d0 +Subproject commit b56154b318b41312faec8a8ebee86c866b47c9f2 diff --git a/components/cmeps b/components/cmeps index 6384ff4e4a..90f815ba9e 160000 --- a/components/cmeps +++ b/components/cmeps @@ -1 +1 @@ -Subproject commit 6384ff4e4a6bc82a678f9419a43ffbd5d53ac209 +Subproject commit 90f815ba9e7493d71043b5d8e627a3f20bd5dc78 diff --git a/src/dynamics/fv3 b/src/dynamics/fv3 index df3550b0f6..66227690a9 160000 --- a/src/dynamics/fv3 +++ b/src/dynamics/fv3 @@ -1 +1 @@ -Subproject commit df3550b0f6a835778f32ccc8c6291942e0413f62 +Subproject commit 66227690a9fb43a64492de32de14562a25ede717 diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index e827ed18df..debb251909 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -1463,10 +1463,10 @@ subroutine tphysac (ztodt, cam_in, & logical :: labort ! abort flag - real(r8) :: surfric(pcols) = 0._r8 ! surface friction velocity - real(r8) :: obklen(pcols) = 0._r8 ! Obukhov length - real(r8) :: fh2o(pcols) = 0._r8 ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) = 0._r8 ! Heat flux for check_energy_chng. + real(r8) surfric(pcols) ! surface friction velocity + real(r8) obklen(pcols) ! Obukhov length + real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space real(r8) :: tmp_ps (pcols) ! tmp space @@ -2117,18 +2117,22 @@ subroutine tphysbc (ztodt, state, & integer :: nstep ! current timestep number - real(r8) :: net_flx(pcols) = 0._r8 - real(r8) :: zdu(pcols,pver) = 0._r8 ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c - real(r8) :: cmfcme(pcols,pver) = 0._r8 ! cmf condensation - evaporation - real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections - real(r8) :: dlf2(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow convections - real(r8) :: rtdt ! 1./ztodt - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + real(r8) :: net_flx(pcols) + + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) rtdt ! 1./ztodt + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. integer :: m, m_cnst ! for macro/micro co-substepping integer :: macmic_it ! iteration variables @@ -2183,13 +2187,13 @@ subroutine tphysbc (ztodt, state, & ! energy checking variables real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) = 0._r8 ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) = 0._r8 ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) = 0._r8 ! vertical integral of liquid from shallow scheme - real(r8) :: det_s (pcols) = 0._r8 ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) = 0._r8 ! vertical integral of detrained ice + real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) = 0._r8 + real(r8) :: flx_heat(pcols) type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes real(r8) :: zero_tracers(pcols,pcnst) diff --git a/src/physics/cam7/physpkg.F90 b/src/physics/cam7/physpkg.F90 index 076ddba799..1c58c417b4 100644 --- a/src/physics/cam7/physpkg.F90 +++ b/src/physics/cam7/physpkg.F90 @@ -1448,16 +1448,16 @@ subroutine tphysac (ztodt, cam_in, & integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep - real(r8) :: net_flx(pcols) = 0._r8 + real(r8) :: net_flx(pcols) - real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections - real(r8) :: rtdt ! 1./ztodt + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) rtdt ! 1./ztodt real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: det_s (pcols) = 0._r8 ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) = 0._r8 ! vertical integral of detrained ice + real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice + real(r8) :: det_ice(pcols) ! vertical integral of detrained ice real(r8) :: flx_cnd(pcols) real(r8) :: zero_sc(pcols*psubcols) ! array of zeros @@ -1489,12 +1489,12 @@ subroutine tphysac (ztodt, cam_in, & logical :: labort ! abort flag - real(r8) :: tvm(pcols,pver) ! virtual temperature - real(r8) :: prect(pcols) ! total precipitation - real(r8) :: surfric(pcols) = 0._r8 ! surface friction velocity - real(r8) :: obklen(pcols) = 0._r8 ! Obukhov length - real(r8) :: fh2o(pcols) = 0._r8 ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) = 0._r8 ! Heat flux for check_energy_chng. + real(r8) tvm(pcols,pver) ! virtual temperature + real(r8) prect(pcols) ! total precipitation + real(r8) surfric(pcols) ! surface friction velocity + real(r8) obklen(pcols) ! Obukhov length + real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry + real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. real(r8) :: tmp_trac (pcols,pver,pcnst) ! tmp space real(r8) :: tmp_pdel (pcols,pver) ! tmp space real(r8) :: tmp_ps (pcols) ! tmp space @@ -2534,18 +2534,22 @@ subroutine tphysbc (ztodt, state, & integer :: nstep ! current timestep number - real(r8) :: net_flx(pcols) = 0._r8 - real(r8) :: zdu(pcols,pver) = 0._r8 ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) = 0._r8 ! Convective mass flux--m sub c - real(r8) :: cmfcme(pcols,pver) = 0._r8 ! cmf condensation - evaporation - real(r8) :: dlf(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow + deep convections - real(r8) :: dlf2(pcols,pver) = 0._r8 ! Detraining cld H20 from shallow convections - real(r8) :: rtdt ! 1./ztodt + real(r8) :: net_flx(pcols) - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i ! column indicex - integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. + real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection + real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c + + real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation + + real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections + real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections + real(r8) rtdt ! 1./ztodt + + integer lchnk ! chunk identifier + integer ncol ! number of atmospheric columns + + integer :: i ! column indicex + integer :: ixcldice, ixcldliq, ixq ! constituent indices for cloud liquid and ice water. integer :: m, m_cnst ! physics buffer fields to compute tendencies for stratiform package @@ -2589,8 +2593,8 @@ subroutine tphysbc (ztodt, state, & real(r8) :: zero(pcols) ! array of zeros real(r8) :: zero_sc(pcols*psubcols) ! array of zeros real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) = 0._r8 ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) = 0._r8 ! vertical integral of liquid from shallow scheme + real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) + real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme real(r8) :: flx_cnd(pcols) real(r8) :: flx_heat(pcols) type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes From b0b79b29fb2d062339615aa731216e125689ecff Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 25 Jul 2024 16:18:16 -0600 Subject: [PATCH 48/75] update gitmodules for new atmospheric_physics tag --- .gitmodules | 4 ++-- src/atmos_phys | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.gitmodules b/.gitmodules index bfe3d8bae1..0637b0a767 100644 --- a/.gitmodules +++ b/.gitmodules @@ -35,8 +35,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/jtruesdal/atmospheric_physics - fxtag = dadadj + url = https://github.com/ESCOMP/atmospheric_physics + fxtag = atmos_phys0_04_000 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index 1e70ee7aa0..ebe25e38fe 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 1e70ee7aa09a08a6c1375c9077118662d174b5ae +Subproject commit ebe25e38fec87c8531760858507e774996cb977e From 55db0bbf7e6f5e0a20d745f147d1dffda7434967 Mon Sep 17 00:00:00 2001 From: Katetc Date: Mon, 29 Jul 2024 12:37:57 -0600 Subject: [PATCH 49/75] Addressing first review comments --- src/physics/cam/clubb_intr.F90 | 8 +------- src/physics/cam/subcol_SILHS.F90 | 6 +++--- 2 files changed, 4 insertions(+), 10 deletions(-) diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 8159d1d63d..223ff0e5b5 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -53,18 +53,12 @@ module clubb_intr type (stats_metadata_type) :: & stats_metadata -!$omp threadprivate(stats_metadata) - type (hm_metadata_type) :: & hm_metadata -!$omp threadprivate(hm_metadata) - type (sclr_idx_type) :: & sclr_idx -!$omp threadprivate(sclr_idx) - #endif private @@ -100,7 +94,7 @@ module clubb_intr real(r8), dimension(nparams), public :: clubb_params_single_col ! Adjustable CLUBB parameters (C1, C2 ...) #endif - ! These are zero by default, but will be set by SILHS before + ! These are zero by default, but will be set by SILHS before they are used by subcolumns integer :: & hydromet_dim = 0, & pdf_dim = 0 diff --git a/src/physics/cam/subcol_SILHS.F90 b/src/physics/cam/subcol_SILHS.F90 index af039a254a..c373ed6b3e 100644 --- a/src/physics/cam/subcol_SILHS.F90 +++ b/src/physics/cam/subcol_SILHS.F90 @@ -373,7 +373,7 @@ subroutine subcol_init_SILHS(pbuf2d) iiNi, & ! Hydrometeor array index for ice concentration, Ni iiNg ! Hydrometeor array index for graupel concentration, Ng - integer :: l ! Loop variable + integer :: l, ierr=0 ! Loop variable, error check ! Set CLUBB's debug level ! This is called in module clubb_intr; no need to do it here. @@ -474,8 +474,8 @@ subroutine subcol_init_SILHS(pbuf2d) !------------------------------- ! Set up hydrometeors and correlation arrays for SILHS !------------------------------- - allocate(corr_array_n_cloud(pdf_dim,pdf_dim)) - allocate(corr_array_n_below(pdf_dim,pdf_dim)) + allocate( corr_array_n_cloud(pdf_dim,pdf_dim), corr_array_n_below(pdf_dim,pdf_dim), stat=ierr) + if( ierr /= 0 ) call endrun(' subcol_init_SILHS: failed to allocate corr_array fields ') corr_file_path_cloud = trim( subcol_SILHS_corr_file_path )//trim( subcol_SILHS_corr_file_name )//cloud_file_ext corr_file_path_below = trim( subcol_SILHS_corr_file_path )//trim( subcol_SILHS_corr_file_name )//below_file_ext From afde46e8837d446e9b98b2cb23d05c8cc074f805 Mon Sep 17 00:00:00 2001 From: Katetc Date: Mon, 29 Jul 2024 13:47:53 -0600 Subject: [PATCH 50/75] A few more review comments --- src/physics/cam/clubb_intr.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 223ff0e5b5..57b220d2a5 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -1844,13 +1844,15 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'W/m2' , 'qt flux (EDMF)' ) end if -#ifndef SILHS - ! hm_metadata is set up by calling init_pdf_hydromet_arrays_api in subcol_init_SILHS. - ! So if we are not using silhs, we allocate the parts of hm_metadata that need allocating - ! in order to making intel debug tests happy. - allocate( hm_metadata%hydromet_list(1) ) - allocate( hm_metadata%l_mix_rat_hm(1) ) -#endif + if ( trim(subcol_scheme) .ne. 'SILHS' ) then + ! hm_metadata is set up by calling init_pdf_hydromet_arrays_api in subcol_init_SILHS. + ! So if we are not using silhs, we allocate the parts of hm_metadata that need allocating + ! in order to making intel debug tests happy. + allocate( hm_metadata%hydromet_list(1), ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate hm_metadata%hydromet_list' ) + allocate( hm_metadata%l_mix_rat_hm(1), ierr) + if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate hm_metadata%l_mix_rat_hm' ) + end if ! Initialize statistics, below are dummy variables dum1 = 300._r8 From b4df86bf3963f85e89470fa89ee82e34280972e9 Mon Sep 17 00:00:00 2001 From: Katetc Date: Mon, 29 Jul 2024 16:14:50 -0600 Subject: [PATCH 51/75] Bug fixes --- src/physics/cam/clubb_intr.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 57b220d2a5..7a07d5bcbd 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -1844,13 +1844,13 @@ subroutine clubb_ini_cam(pbuf2d) call addfld ( 'edmf_qtflx' , (/ 'ilev' /), 'A', 'W/m2' , 'qt flux (EDMF)' ) end if - if ( trim(subcol_scheme) .ne. 'SILHS' ) then + if ( trim(subcol_scheme) /= 'SILHS' ) then ! hm_metadata is set up by calling init_pdf_hydromet_arrays_api in subcol_init_SILHS. ! So if we are not using silhs, we allocate the parts of hm_metadata that need allocating ! in order to making intel debug tests happy. - allocate( hm_metadata%hydromet_list(1), ierr) + allocate( hm_metadata%hydromet_list(1), stat=ierr) if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate hm_metadata%hydromet_list' ) - allocate( hm_metadata%l_mix_rat_hm(1), ierr) + allocate( hm_metadata%l_mix_rat_hm(1), stat=ierr) if( ierr /= 0 ) call endrun( 'clubb_ini_cam: Unable to allocate hm_metadata%l_mix_rat_hm' ) end if From a251e59f94f1f9a8e3eded064a59c5a2698c7a62 Mon Sep 17 00:00:00 2001 From: Katetc Date: Tue, 30 Jul 2024 14:14:32 -0600 Subject: [PATCH 52/75] Update ChangeLog template to include nvhpc tests on Derecho --- doc/ChangeLog_template | 2 ++ 1 file changed, 2 insertions(+) diff --git a/doc/ChangeLog_template b/doc/ChangeLog_template index 5919b4e11a..f646f24e78 100644 --- a/doc/ChangeLog_template +++ b/doc/ChangeLog_template @@ -31,6 +31,8 @@ appropriate machine below. All failed tests must be justified. derecho/intel/aux_cam: +derecho/nvhpc/aux_cam: + izumi/nag/aux_cam: izumi/gnu/aux_cam: From b52730b6b89c48ebbde38027704ef4b613384ca2 Mon Sep 17 00:00:00 2001 From: katetc Date: Wed, 31 Jul 2024 14:40:19 -0600 Subject: [PATCH 53/75] Bug fix for runs where CLUBB_SGS is not defined --- src/physics/cam/clubb_intr.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/physics/cam/clubb_intr.F90 b/src/physics/cam/clubb_intr.F90 index 7a07d5bcbd..361f71e57f 100644 --- a/src/physics/cam/clubb_intr.F90 +++ b/src/physics/cam/clubb_intr.F90 @@ -41,24 +41,22 @@ module clubb_intr #endif implicit none + #ifdef CLUBB_SGS ! Variables that contains all the statistics - type (stats), target, save :: stats_zt(pcols), & ! stats_zt grid stats_zm(pcols), & ! stats_zm grid stats_rad_zt(pcols), & ! stats_rad_zt grid stats_rad_zm(pcols), & ! stats_rad_zm grid stats_sfc(pcols) ! stats_sfc - - type (stats_metadata_type) :: & - stats_metadata - type (hm_metadata_type) :: & hm_metadata + + type (stats_metadata_type) :: & + stats_metadata type (sclr_idx_type) :: & sclr_idx - #endif private @@ -103,6 +101,7 @@ module clubb_intr ! ------------------------ ! ! Sometimes private data ! ! ------------------------ ! +#ifdef CLUBB_SGS #ifdef SILHS ! If SILHS is in use, it will initialize these public :: & @@ -116,7 +115,8 @@ module clubb_intr pdf_dim, & hm_metadata #endif - +#endif + ! ------------ ! ! Private data ! ! ------------ ! From 2ae76b01786f931fbb6ca456e0a8f6808e71a719 Mon Sep 17 00:00:00 2001 From: Francis Vitt Date: Mon, 5 Aug 2024 17:16:17 -0600 Subject: [PATCH 54/75] cycle forcings over appropriate year modified: bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml modified: bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml --- bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml | 4 ++-- bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml b/bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml index cdb217a987..040cf5acfc 100644 --- a/bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml +++ b/bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml @@ -21,8 +21,8 @@ 'CO2','CH4','N2O','CFC11','CFC12','CFC11eq' -FIXED -20000101 +CYCLICAL +2000 SCWACCM_forcing_WACCM6_zm_5day_L70_1975-2014_c191121.nc atm/waccm/waccm_forcing diff --git a/bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml b/bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml index d878ba8f6d..a77688d0f1 100644 --- a/bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml +++ b/bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml @@ -21,8 +21,8 @@ 'CO2','CH4','N2O','CFC11','CFC12','CFC11eq' -FIXED -20100101 +CYCLICAL +2010 SCWACCM_forcing_WACCM6_zm_5day_L70_1975-2014_c191121.nc atm/waccm/waccm_forcing From dcc636d33ab3d4e0ba06425df2f07dbadebcbc6f Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Mon, 5 Aug 2024 21:37:24 -0600 Subject: [PATCH 55/75] PR updates: comments,typo, and replace hard coded length with shr_kind_cl --- bld/namelist_files/namelist_defaults_cam.xml | 2 +- src/control/scamMod.F90 | 4 ++-- src/dynamics/se/advect_tend.F90 | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/bld/namelist_files/namelist_defaults_cam.xml b/bld/namelist_files/namelist_defaults_cam.xml index 49c7a45efe..1ee274db85 100644 --- a/bld/namelist_files/namelist_defaults_cam.xml +++ b/bld/namelist_files/namelist_defaults_cam.xml @@ -3006,7 +3006,7 @@ 172800.D0 - + atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index 44a3a45cc2..425c7412e9 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -19,7 +19,7 @@ module scamMod ! scam_readnl !----------------------------------------------------------------------- -use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl use spmd_utils, only: masterproc,npes use pmgrid, only: plon, plat, plev, plevp use constituents, only: cnst_get_ind, pcnst, cnst_name @@ -1396,7 +1396,7 @@ subroutine get_start_count (ncid ,varid ,scmlat, scmlon, timeidx, start , !---------------------------Local workspace----------------------------- integer :: dims_set,nlev,var_ndims logical :: usable_var - character(len=256) :: dim_name + character(len=cl) :: dim_name integer :: var_dimIDs( NF90_MAX_VAR_DIMS ) real(r8) :: closelat,closelon integer :: latidx,lonidx,status,i diff --git a/src/dynamics/se/advect_tend.F90 b/src/dynamics/se/advect_tend.F90 index 815bc51135..3512b57507 100644 --- a/src/dynamics/se/advect_tend.F90 +++ b/src/dynamics/se/advect_tend.F90 @@ -146,7 +146,7 @@ subroutine compute_write_iop_fields(elem,fvm,nets,nete,qn0,n0) if (ierr/=0) call endrun( sub//': not able to allocate derivedfq' ) derivedfq = 0._r8 allocate( iop_qtendxyz_init(nx,nx,nlev,pcnst,nets:nete),stat=ierr ) - if (ierr/=0) call endrun( sub//': not able to allocate ipo_qtendxyz' ) + if (ierr/=0) call endrun( sub//': not able to allocate iop_qtendxyz' ) iop_qtendxyz_init = 0._r8 allocate( iop_ttendxyz(nx,nx,nlev,nets:nete),stat=ierr ) if (ierr/=0) call endrun( sub//': not able to allocate iop_ttendxyz' ) From 2abc5a0164cab1476a79554b8ea59dfad74c179d Mon Sep 17 00:00:00 2001 From: katetc Date: Thu, 8 Aug 2024 20:44:53 -0600 Subject: [PATCH 56/75] Update to new new new CLUBB external (_gpufix_PosInf) and new CDEPS --- .gitmodules | 4 ++-- components/cdeps | 2 +- src/physics/clubb | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index 1b4b6d1d1c..dff6e524c6 100644 --- a/.gitmodules +++ b/.gitmodules @@ -96,7 +96,7 @@ url = https://github.com/larson-group/clubb_release fxrequired = AlwaysRequired fxsparse = ../.clubb_sparse_checkout - fxtag = clubb_4ncar_20240605_73d60f6 + fxtag = clubb_4ncar_20240605_73d60f6_gpufixes_posinf fxDONOTUSEurl = https://github.com/larson-group/clubb_release [submodule "cism"] @@ -151,7 +151,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps url = https://github.com/ESCOMP/CDEPS.git -fxtag = cdeps1.0.43 +fxtag = cdeps1.0.44 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git diff --git a/components/cdeps b/components/cdeps index 453a9d175a..b7a6088204 160000 --- a/components/cdeps +++ b/components/cdeps @@ -1 +1 @@ -Subproject commit 453a9d175a5739d9cca5c4ec7b96f45b201decec +Subproject commit b7a608820480ee9a79f11e37e88bf740350f51b5 diff --git a/src/physics/clubb b/src/physics/clubb index 4b3e80faef..15e802092f 160000 --- a/src/physics/clubb +++ b/src/physics/clubb @@ -1 +1 @@ -Subproject commit 4b3e80faefdbbe79cda650a8401364ec640e05e7 +Subproject commit 15e802092f65b3a20e5d67cb32d40f8a2771ca9b From 8e05c34e5bb2c3d1b9e0eb87f9a697d16e412391 Mon Sep 17 00:00:00 2001 From: Katetc Date: Fri, 9 Aug 2024 12:33:05 -0600 Subject: [PATCH 57/75] Update to newest CDEPS tag cdeps1.0.45 --- .gitmodules | 2 +- components/cdeps | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index dff6e524c6..811bd080f3 100644 --- a/.gitmodules +++ b/.gitmodules @@ -151,7 +151,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps url = https://github.com/ESCOMP/CDEPS.git -fxtag = cdeps1.0.44 +fxtag = cdeps1.0.45 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git diff --git a/components/cdeps b/components/cdeps index b7a6088204..46c10740ce 160000 --- a/components/cdeps +++ b/components/cdeps @@ -1 +1 @@ -Subproject commit b7a608820480ee9a79f11e37e88bf740350f51b5 +Subproject commit 46c10740ce83a154edfc876093f72e7f041c3659 From 86ba7de6bff6fbb966e8f50da6cec1e8d9d6a8ed Mon Sep 17 00:00:00 2001 From: katetc Date: Fri, 9 Aug 2024 17:52:41 -0600 Subject: [PATCH 58/75] Update ChangeLog with Derecho test results before machine goes down --- doc/ChangeLog | 101 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 101 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 93142a1a4a..a5f3894e34 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,106 @@ =============================================================== +Tag name: cam6_4_019 +Originator(s): katec, cacraig, vlarson, bstephens82, huebleruwm, zarzycki, JulioTBacmeister, jedwards4b +Date: 10 August 2024 +One-line Summary: New CLUBB external, new GPU/nvhpc test suite, new CDEPS external +Github PR URL: https://github.com/ESCOMP/CAM/pull/1086 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +Describe any changes made to build system: update git-fleximod + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: none + +Code reviewed by: cacraigucar + +List all files eliminated: none + +List all files added and what they do: + +List all existing files that have been modified, and describe the changes: + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +- pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + +SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: +- pre-existing failures -- need fix in CLM external + +SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +- pre-existing failure -- need fix in CICE external + +ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: +ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: +ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: +ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: +ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: +ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: +ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 (Overall: DIFF) details: +ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: +ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: +SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: +SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: +SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: +SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: +SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FCts4MTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: +SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: +SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: +SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: +SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: +SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: +SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: +SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: +SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: DIFF) details: +SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: +SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: +- Expected differences due to the new CLUBB external (See PR for discussion) + +derecho/nvphc/aux_cam: + +ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default (Overall: DIFF) + FAIL ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default BASELINE /glade/campaign/cesm/community/amwg/cam_baselines/cam6_4_018_intel: ERROR BFAIL baseline directory '/glade/campaign/cesm/community/amwg/cam_baselines/cam6_4_018_intel/ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default' does not exist +- Expected baseline compare fail due to no baselines stored for GPU tests that didn't exist previously + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB, as expected + +=============================================================== + Tag name: cam6_4_018 Originator(s): peverwhee, jedwards4b Date: 30 July 2024 From ed684d2c73f6db60c6edf664ae2fad41ffd0578d Mon Sep 17 00:00:00 2001 From: katetc Date: Mon, 12 Aug 2024 16:50:25 -0600 Subject: [PATCH 59/75] Final updates --- doc/ChangeLog | 65 ++++++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 57 insertions(+), 8 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a5f3894e34..077a11ada7 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,27 +2,59 @@ Tag name: cam6_4_019 Originator(s): katec, cacraig, vlarson, bstephens82, huebleruwm, zarzycki, JulioTBacmeister, jedwards4b -Date: 10 August 2024 +Date: 12 August 2024 One-line Summary: New CLUBB external, new GPU/nvhpc test suite, new CDEPS external Github PR URL: https://github.com/ESCOMP/CAM/pull/1086 Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - New CLUBB external with fixes to support GPU testing #1036 + - part of cam6_4_019: Add GPU regression test suite #1048 -Describe any changes made to build system: update git-fleximod +Describe any changes made to build system: none -Describe any changes made to the namelist: none +Describe any changes made to the namelist: + - Add default vaules for a few new CLUBB namelist parameters: clubb_bv_efold, clubb_wpxp_Ri_exp, and clubb_z_displace List any changes to the defaults for the boundary datasets: none Describe any substantial timing or memory changes: none -Code reviewed by: cacraigucar +Code reviewed by: cacraigucar, sjsprecious, adamrher, bstephens82 -List all files eliminated: none +List all files eliminated: + cime/config/testmods_dirs/cam/outfrq9s_mg3_nondefault/shell_comands + cime/config/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_cam + cime/config/testmods_dirs/cam/outfrq9s_mg3_nondefault/user_nl_clm + - Removed as part of GPU test updates -List all files added and what they do: +List all files added and what they do: None List all existing files that have been modified, and describe the changes: + .gitmodules + - Point to new CLUBB external (clubb_4ncar_20240605_73d60f6_gpufixes_posinf) + and new CDEPS external (cdeps1.0.45) + + cime/config/testdefs/testlist_cam.xml + - Add nvhpc gpu test on Derecho, remove Casper tests + + cime/config/testdefs/testmods_dirs/cam/outfrq9s_mg2_default/shell_commands + cime/config/testdefs/testmods_dirs/cam/outfrq9s_mg3_default/shell_commands + - Change NTASKS for Derecho gpus + + cime/config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols1536/ + - Directory renamed to cime/config/testdefs/testmods_dirs/cam/outfrq9s_mg3_pcols760 + - Files updated to reflect the change + + doc/ChangeLog_template + - Added space for new derecho/nvhpc required tests + + src/physics/cam/clubb_intr.F90 + src/physics/cam/subcol_SILHS.F90 + - Updates to support the new external + + test/system/archive_baseline.sh + test/system/test_driver.sh + - Updates to require CAM_FC compiler specification on Derecho (either intel or nvhpc) If there were any failures reported from running test_driver.sh on any test platform, and checkin with these failures has been OK'd by the gatekeeper, @@ -91,13 +123,30 @@ ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s - Expected baseline compare fail due to no baselines stored for GPU tests that didn't exist previously izumi/nag/aux_cam: +DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: +- pre-existing failure - issue #670 + +ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: +ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: +ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: +ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: +ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: +ERP_Ln9.ne5pg3_ne5pg3_mg37.QPC6.izumi_nag.cam-outfrq9s_clubbmf (Overall: DIFF) details: +SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: +SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: +- Expected differences due to the new CLUBB external (See PR for discussion) izumi/gnu/aux_cam: +ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: +ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: +- Expected differences due to the new CLUBB external (See PR for discussion) CAM tag used for the baseline comparison tests if different than previous -tag: +tag: cam6_4_018 -Summarize any changes to answers: BFB, as expected +Summarize any changes to answers: + All compsets that use CLUBB (cam6+) will have slight answer changes. Discussion in PR. + Nvhpc gpu tests have no stored baseline for comparison. =============================================================== From 44952ccdec9b72552cdacf06e15f969d14db1bf8 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Tue, 13 Aug 2024 10:47:53 -0600 Subject: [PATCH 60/75] Add compiler name to derecho baseline directories --- test/system/archive_baseline.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/system/archive_baseline.sh b/test/system/archive_baseline.sh index e457081ba4..f64561dc4d 100755 --- a/test/system/archive_baseline.sh +++ b/test/system/archive_baseline.sh @@ -76,7 +76,7 @@ case $hostname in echo "Must specify CAM_FC" fi test_file_list="tests_pretag_derecho_${CAM_FC,,}" - cam_tag=$1 + cam_tag=$1_${CAM_FC,,} baselinedir="/glade/campaign/cesm/community/amwg/cam_baselines/$cam_tag" ;; From f675c4098ccd13e879db2c2f3d54ef0b7c7e5052 Mon Sep 17 00:00:00 2001 From: Francis Vitt Date: Tue, 13 Aug 2024 12:43:40 -0600 Subject: [PATCH 61/75] ChangeLog draft --- doc/ChangeLog | 81 ++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 80 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 077a11ada7..a90cf19c3f 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,84 @@ =============================================================== +Tag name: cam6_4_020 +Originator(s): fvitt +Date: 13 Aug 2024 +One-line Summary: Correction to aerosol convective removal and other misc fixes +Github PR URL: https://github.com/ESCOMP/CAM/pull/1111 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + + Fixes to the follow: + . an error in the calculation of dz in the aerosol convective removal code + . issue #1030 -- Incorrect waccm_forcing namelist settings in FWsc2000climo and FWsc2010climo compsets + . issue #1125 -- archive_baselines does not append compiler onto derecho baselines properly + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: cacraigucar + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M bld/namelist_files/use_cases/waccm_sc_2000_cam6.xml +M bld/namelist_files/use_cases/waccm_sc_2010_cam6.xml + - corrections to waccm_forcing namelist settings + +M src/chemistry/modal_aero/modal_aero_convproc.F90 + - correctly calculate dz + - misc code clean up + +M test/system/archive_baseline.sh + - append compiler name to tag name used in baseline path + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +derecho/nvhpc/aux_cam: + +izumi/nag/aux_cam: + +izumi/gnu/aux_cam: + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: +- what platforms/compilers: +- nature of change (roundoff; larger than roundoff but same climate; new + climate): + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +If this tag changes climate describe the run(s) done to evaluate the new +climate in enough detail that it(they) could be reproduced, i.e., +- source tag (all code used must be in the repository): +- platform/compilers: +- configure commandline: +- build-namelist command (or complete namelist): +- MSS location of output: + +MSS location of control simulations used to validate new climate: + +URL for AMWG diagnostics output used to validate new climate: + +=============================================================== +=============================================================== + Tag name: cam6_4_019 Originator(s): katec, cacraig, vlarson, bstephens82, huebleruwm, zarzycki, JulioTBacmeister, jedwards4b Date: 12 August 2024 @@ -310,7 +389,7 @@ Issue #1063 - Possible modification to RRTMG-P for ~80km top model as well as the cam7-MT configuration. Note that this modification is still being tested for scientific validity - in the cam7-MT configuration. + in the cam7-MT configuration. Issue #1097 - HEMCO reference in .gitmodules is a branch not a tag. . Modify .gitmodules to resolve #1097 From d434571b56d1f49f69bf3148b8494d6fdf488487 Mon Sep 17 00:00:00 2001 From: Francis Vitt Date: Wed, 14 Aug 2024 07:49:29 -0600 Subject: [PATCH 62/75] ChangeLog update --- doc/ChangeLog | 93 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 72 insertions(+), 21 deletions(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index a90cf19c3f..26d357a79b 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ Tag name: cam6_4_020 Originator(s): fvitt -Date: 13 Aug 2024 +Date: 14 Aug 2024 One-line Summary: Correction to aerosol convective removal and other misc fixes Github PR URL: https://github.com/ESCOMP/CAM/pull/1111 @@ -45,37 +45,88 @@ then copy the lines from the td.*.status files for the failed tests to the appropriate machine below. All failed tests must be justified. derecho/intel/aux_cam: + FAIL ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 -derecho/nvhpc/aux_cam: + FAIL SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s + - pre-existing failure -- need fix in CICE external -izumi/nag/aux_cam: + PEND SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s + PEND SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s + - pre-existing failures -- need fix in CLM external -izumi/gnu/aux_cam: + DIFF ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp + DIFF ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase + DIFF ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s + DIFF ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s + DIFF ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp + DIFF ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s + DIFF ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d + DIFF ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 + DIFF ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s + DIFF ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes + DIFF ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 + DIFF ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s + DIFF ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s + DIFF ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 + DIFF ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 + DIFF SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday + DIFF SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 + DIFF SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie + DIFF SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase + DIFF SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FCts4MTHIST.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s + DIFF SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s + DIFF SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d + DIFF SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d + DIFF SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d + DIFF SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h + DIFF SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m + DIFF SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging + DIFF SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s + DIFF SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp + - expected baseline test failures due to correction in modal_aero_convproc -CAM tag used for the baseline comparison tests if different than previous -tag: +derecho/nvhpc/aux_cam: + DIFF ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default + - expected baseline test failure due to correction in modal_aero_convproc -Summarize any changes to answers, i.e., -- what code configurations: -- what platforms/compilers: -- nature of change (roundoff; larger than roundoff but same climate; new - climate): +izumi/nag/aux_cam: + FAIL DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae + - pre-existing failure - issue #670 -If bitwise differences were observed, how did you show they were no worse -than roundoff? + DIFF ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am + DIFF ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist + DIFF ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s + DIFF ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s + DIFF ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 + DIFF SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase + - expected baseline test failures due to correction in modal_aero_convproc -If this tag changes climate describe the run(s) done to evaluate the new -climate in enough detail that it(they) could be reproduced, i.e., -- source tag (all code used must be in the repository): -- platform/compilers: -- configure commandline: -- build-namelist command (or complete namelist): -- MSS location of output: +izumi/gnu/aux_cam: + DIFF ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s + DIFF ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp + DIFF SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 + - expected baseline test failures due to correction in modal_aero_convproc -MSS location of control simulations used to validate new climate: +Summarize any changes to answers: + larger than roundoff but same climate URL for AMWG diagnostics output used to validate new climate: + https://acomstaff.acom.ucar.edu/tilmes/amwg/cam7/f.e23_beta02.FLTHIST_ne30.conv_dz_bug_1995_2004_vs_f.e23_beta02.FLTHIST_ne30.001_1995_2004/website/index.html + https://acomstaff.acom.ucar.edu/tilmes/amwg/cam7/f.cam6_3_160.FMTHIST_ne30.moving_mtn.output.conv7_1996_2004_vs_f.cam6_3_160.FMTHIST_ne30.moving_mtn.output.conv6_1996_2004/website/html_table/mean_tables.html + =============================================================== =============================================================== From f5c1ab0ec6d9857a6466d6a7fcac90029f53e4c8 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Wed, 14 Aug 2024 09:38:53 -0600 Subject: [PATCH 63/75] Remove 0.5*timestep logic from call to zm --- .gitmodules | 4 ++-- src/atmos_phys | 2 +- src/physics/cam/zm_conv_intr.F90 | 8 ++++---- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/.gitmodules b/.gitmodules index 4600960184..6f35e3801c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -35,8 +35,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/ESCOMP/atmospheric_physics - fxtag = atmos_phys0_03_000 + url = https://github.com/cacraigucar/atmospheric_physics + fxtag = 4f0766db fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics diff --git a/src/atmos_phys b/src/atmos_phys index f4c09618ea..4f0766db70 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit f4c09618eaaa19eaf3382f0473a531e20aa9f808 +Subproject commit 4f0766db70efe8c8ad49161c101ba949ae9f5029 diff --git a/src/physics/cam/zm_conv_intr.F90 b/src/physics/cam/zm_conv_intr.F90 index b80fcf504d..0bd98e86b2 100644 --- a/src/physics/cam/zm_conv_intr.F90 +++ b/src/physics/cam/zm_conv_intr.F90 @@ -249,8 +249,8 @@ subroutine zm_conv_init(pref_edge) ! local variables real(r8), parameter :: scale_height = 7000._r8 ! std atm scale height (m) - real(r8), parameter :: dz_min = 100._r8 ! minimum thickness for using - ! zmconv_parcel_pbl=.false. + real(r8), parameter :: dz_min = 100._r8 ! minimum thickness for using + ! zmconv_parcel_pbl=.false. real(r8) :: dz_bot_layer ! thickness of bottom layer (m) character(len=512) :: errmsg @@ -847,7 +847,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ptend_loc%lq,state1%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:), ztodt) + nstep, fracis(:ncol,:,:), ptend_loc%q(:ncol,:,:), fake_dpdry(:ncol,:)) call t_stopf ('convtran1') call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) @@ -947,7 +947,7 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol), maxg(:ncol), ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ztodt) + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:)) call t_stopf ('convtran2') end if From 0a09ac08fc1f9b6841800de02be53e988a04be9f Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Thu, 15 Aug 2024 16:51:34 -0600 Subject: [PATCH 64/75] Update atmos_phys tag --- .gitmodules | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitmodules b/.gitmodules index 6f35e3801c..9f81b3ea05 100644 --- a/.gitmodules +++ b/.gitmodules @@ -35,8 +35,8 @@ [submodule "atmos_phys"] path = src/atmos_phys - url = https://github.com/cacraigucar/atmospheric_physics - fxtag = 4f0766db + url = https://github.com/ESCOMP/atmospheric_physics + fxtag = atmos_phys0_04_001 fxrequired = AlwaysRequired fxDONOTUSEurl = https://github.com/ESCOMP/atmospheric_physics From cdf72282e2941d90e7f1fbec8bcae30f0dea17fc Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Fri, 16 Aug 2024 09:15:40 -0600 Subject: [PATCH 65/75] Update atmos_phys tag --- src/atmos_phys | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/atmos_phys b/src/atmos_phys index 4f0766db70..d9d0e5d9bf 160000 --- a/src/atmos_phys +++ b/src/atmos_phys @@ -1 +1 @@ -Subproject commit 4f0766db70efe8c8ad49161c101ba949ae9f5029 +Subproject commit d9d0e5d9bf96e5386ccb264bf123f8007db5821d From d36b4ed63b06a460b2a2208c88934f702bbad2aa Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 16 Aug 2024 20:13:19 -0600 Subject: [PATCH 66/75] update ChangeLog and add back # to first line of test_driver.sh --- doc/ChangeLog | 71 ++++++++++++++++++++++++++++++++++++++ test/system/test_driver.sh | 2 +- 2 files changed, 72 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index 26d357a79b..b62f165c26 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,5 +1,76 @@ =============================================================== +Tag name: cam6_4_021 +Originator(s): jet +Date: 8 Aug 2024 +One-line Summary: CCPPize dadadj +Github PR URL: https://github.com/ESCOMP/CAM/pull/1026 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Issue #928 - Convert Dry Adiabatic Adjustment to CCPP and move into the atmospheric_physics github repo + +Describe any changes made to build system: add atmos_phys/dry_adiabatic_adjust directory to build filepath + +Describe any changes made to the namelist: none + +List any changes to the defaults for the boundary datasets: none + +Describe any substantial timing or memory changes: none + +Code reviewed by: cacraigucar, nusbaume + +List all files eliminated: +D physics/cam/dadadj.F90 + +List all files added and what they do: none + +List all existing files that have been modified, and describe the changes: + +M .gitmodules + - update to atmospheric_physics tag with new dry_adiabatic_adjust ccpp routine + +M bld/configure + - Add dry_adiabatic_adjust to build Filepath +M src/cam_snapshot_common.F90 + - update pbuf_snapshot fields from 250 to 300 +M physics/cam/dadadj_cam.F90 + - CCPP'ize dadadj interface +M physics/physpkg.F90 +M physics/cam7/physpkg.F90 + - update subroutine name for cam dadadj initialization + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +- pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + +SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: +- pre-existing failures -- need fix in CLM external + +SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +- pre-existing failure -- need fix in CICE external + +derecho/nvphc/aux_cam: All Pass + +izumi/nag/aux_cam: +DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: +- pre-existing failure - issue #670 + + +izumi/gnu/aux_cam: All Pass + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers: BFB, as expected + +=============================================================== + Tag name: cam6_4_020 Originator(s): fvitt Date: 14 Aug 2024 diff --git a/test/system/test_driver.sh b/test/system/test_driver.sh index ef86e43cb8..a53d0762d8 100755 --- a/test/system/test_driver.sh +++ b/test/system/test_driver.sh @@ -1,4 +1,4 @@ -!/bin/sh +#!/bin/sh # # test_driver.sh: driver for the testing of CAM with standalone scripts # From cf34bea6c90051aec5046dba3e27c0fef800bd90 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 16 Aug 2024 21:25:44 -0600 Subject: [PATCH 67/75] fix date of ChangeLog entry --- doc/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ChangeLog b/doc/ChangeLog index b62f165c26..6f9974c465 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,12 +2,13 @@ Tag name: cam6_4_021 Originator(s): jet -Date: 8 Aug 2024 +Date: 16 Aug 2024 One-line Summary: CCPPize dadadj Github PR URL: https://github.com/ESCOMP/CAM/pull/1026 Purpose of changes (include the issue number and title text for each relevant GitHub issue): - Issue #928 - Convert Dry Adiabatic Adjustment to CCPP and move into the atmospheric_physics github repo + - Bugfix to dadadj although it didn't change answers in the regression suite. Describe any changes made to build system: add atmos_phys/dry_adiabatic_adjust directory to build filepath From e381582d7ff0d2c7ac2dcea3b4de339c0d8fc816 Mon Sep 17 00:00:00 2001 From: Jesse Nusbaumer Date: Mon, 19 Aug 2024 11:29:23 -0600 Subject: [PATCH 68/75] Remove project checks from issue-closing script. --- .github/scripts/branch_pr_issue_closer.py | 256 +++------------------- 1 file changed, 32 insertions(+), 224 deletions(-) diff --git a/.github/scripts/branch_pr_issue_closer.py b/.github/scripts/branch_pr_issue_closer.py index 429fd498e6..d4c3438cad 100755 --- a/.github/scripts/branch_pr_issue_closer.py +++ b/.github/scripts/branch_pr_issue_closer.py @@ -21,8 +21,6 @@ import re import sys -import subprocess -import shlex import argparse from github import Github @@ -31,42 +29,6 @@ #HELPER FUNCTIONS ################# -#+++++++++++++++++++++++++++++++++++++++++ -#Curl command needed to move project cards -#+++++++++++++++++++++++++++++++++++++++++ - -def project_card_move(oa_token, column_id, card_id): - - """ - Currently pyGithub doesn't contain the methods required - to move project cards from one column to another, so - the unix curl command must be called directly, which is - what this function does. - - The specific command-line call made is: - - curl -H "Authorization: token OA_token" -H \ - "Accept: application/vnd.github.inertia-preview+json" \ - -X POST -d '{"position":"top", "column_id":}' \ - https://api.github.com/projects/columns/cards//moves - - """ - - #create required argument strings from inputs: - github_oa_header = ''' "Authorization: token {0}" '''.format(oa_token) - github_url_str = '''https://api.github.com/projects/columns/cards/{0}/moves'''.format(card_id) - json_post_inputs = ''' '{{"position":"top", "column_id":{}}}' '''.format(column_id) - - #Create curl command line string: - curl_cmdline = '''curl -H '''+github_oa_header+''' -H "Accept: application/vnd.github.inertia-preview+json" -X POST -d '''+\ - json_post_inputs+''' '''+github_url_str - - #Split command line string into argument list: - curl_arg_list = shlex.split(curl_cmdline) - - #Run command using subprocess: - subprocess.run(curl_arg_list, check=True) - #++++++++++++++++++++++++++++++ #Input Argument parser function #++++++++++++++++++++++++++++++ @@ -101,7 +63,7 @@ def end_script(msg): """ Prints message to screen, and then exits script. """ - print("\n{}\n".format(msg)) + print(f"\n{msg}\n") print("Issue closing check has completed successfully.") sys.exit(0) @@ -137,11 +99,10 @@ def _main_prog(): ghub = Github(token) - #++++++++++++++++++++ - #Open ESCOMP/CAM repo - #++++++++++++++++++++ + #+++++++++++++++++++++ + #Open NCAR/CAMDEN repo + #+++++++++++++++++++++ - #Official CAM repo: cam_repo = ghub.get_repo("ESCOMP/CAM") #+++++++++++++++++++++++++++++ @@ -162,6 +123,9 @@ def _main_prog(): #Search for merge text, starting at beginning of message: commit_msg_match = pr_merge_pattern.match(commit_message) + #Initialize variables: + pr_num = 0 + #Check if match exists: if commit_msg_match is not None: #If it does then pull out text immediately after message: @@ -174,7 +138,7 @@ def _main_prog(): first_word = post_msg_word_list[0] #Print merged pr number to screen: - print("Merged PR: {}".format(first_word)) + print(f"Merged PR: {first_word}") try: #Try assuming the word is just a number: @@ -251,6 +215,7 @@ def _main_prog(): pr_msg_lower = merged_pull.body.lower() #search for at least one keyword: + word_matches = [] if keyword_pattern.search(pr_msg_lower) is not None: #If at least one keyword is found, then determine location of every keyword instance: word_matches = keyword_pattern.finditer(pr_msg_lower) @@ -258,9 +223,9 @@ def _main_prog(): endmsg = "Pull request was merged without using any of the keywords. Thus there are no issues to close." end_script(endmsg) - #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - #Extract issue and PR numbers associated with found keywords in merged PR message - #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + #Extract issue and PR numbers associated with found keywords in merged PR message + #++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ #create issue pattern ("the number symbol {#} + a number"), #which ends with either a space, a comma, a period, or @@ -268,10 +233,10 @@ def _main_prog(): issue_pattern = re.compile(r'#[0-9]+(\s|,|$)|.') #Create new "close" issues list: - close_issues = list() + close_issues = [] #Create new "closed" PR list: - close_pulls = list() + close_pulls = [] #Search text right after keywords for possible issue numbers: for match in word_matches: @@ -299,13 +264,13 @@ def _main_prog(): #so set the issue number to one that will never be found: issue_num = -9999 - #Check that number is actually for an issue (as opposed to a PR): - if issue_num in open_issues: - #Add issue number to "close issues" list: - close_issues.append(issue_num) - elif issue_num in open_pulls: - #If in fact a PR, then add to PR list: + #Check if number is actually for a PR (as opposed to an issue): + if issue_num in open_pulls: + #Add PR number to "close pulls" list: close_pulls.append(issue_num) + elif issue_num in open_issues: + #If in fact an issue, then add to "close issues" list: + close_issues.append(issue_num) #If no issue numbers are present after any of the keywords, then exit script: if not close_issues and not close_pulls: @@ -322,183 +287,26 @@ def _main_prog(): print("PRs referenced by the merged PR: "+", ".join(\ str(pull) for pull in close_pulls)) - #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - #Determine name of project associated with merged Pull Request - #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - #Pull-out all projects from repo: - projects = cam_repo.get_projects() - - #Initalize modified project name: - proj_mod_name = None - - #Loop over all repo projects: - for project in projects: - #Pull-out columns from each project: - proj_columns = project.get_columns() - - #Loop over columns: - for column in proj_columns: - - #check if column name is "Completed Tags" - if column.name == "Completed tags": - #If so, then extract cards: - cards = column.get_cards() - - #Loop over cards: - for card in cards: - #Extract card content: - card_content = card.get_content() - - #Next, check if card number exists and matches merged PR number: - if card_content is not None and card_content.number == pr_num: - #If so, and if Project name is None, then set string: - if proj_mod_name is None: - proj_mod_name = project.name - #Break out of card loop: - break - - #If already set, then somehow merged PR is in two different projects, - #which is not what this script is expecting, so just exit: - endmsg = "Merged Pull Request found in two different projects, so script will do nothing." - end_script(endmsg) - - #Print project name associated with merged PR: - print("merged PR project name: {}".format(proj_mod_name)) - - #++++++++++++++++++++++++++++++++++++++++ - #Extract repo project "To do" card issues - #++++++++++++++++++++++++++++++++++++++++ - - #Initalize issue counting dictionary: - proj_issues_count = dict() - - #Initalize issue id to project card id dictionary: - proj_issue_card_ids = dict() - - #Initialize list for issues that have already been closed: - already_closed_issues = list() - - #Loop over all repo projects: - for project in projects: - - #Next, pull-out columns from each project: - proj_columns = project.get_columns() - - #Loop over columns: - for column in proj_columns: - #Check if column name is "To do" - if column.name == "To do": - #If so, then extract cards: - cards = column.get_cards() - - #Loop over cards: - for card in cards: - #Extract card content: - card_content = card.get_content() - - #Next, check if card issue number matches any of the "close" issue numbers from the PR: - if card_content is not None and card_content.number in close_issues: - - #If so, then check if issue number is already in proj_issues_count: - if card_content.number in proj_issues_count: - #Add one to project issue counter: - proj_issues_count[card_content.number] += 1 - - #Also add issue id and card id to id dictionary used for card move, if in relevant project: - if project.name == proj_mod_name: - proj_issue_card_ids[card_content.number] = card.id - - else: - #If not, then append to project issues count dictionary: - proj_issues_count[card_content.number] = 1 - - #Also add issue id and card id to id dictionary used for card move, if in relevant project: - if project.name == proj_mod_name: - proj_issue_card_ids[card_content.number] = card.id - - #Otherwise, check if column name matches "closed issues" column: - elif column.name == "closed issues" and project.name == proj_mod_name: - #Save column id: - column_target_id = column.id - - #Extract cards: - closed_cards = column.get_cards() - - #Loop over cards: - for closed_card in closed_cards: - #Extract card content: - closed_card_content = closed_card.get_content() - - #Check if card issue number matches any of the "close" issue numbers from the PR: - if closed_card_content is not None and closed_card_content.number in close_issues: - #If issue number matches, then it likely means the same - #commit message or issue number reference was used in multiple - #pushes to the same repo (e.g., for a PR and then a tag). Thus - #the issue should be marked as "already closed": - already_closed_issues.append(closed_card_content.number) - - #Remove all issues from issue dictionary that are "already closed": - for already_closed_issue_num in already_closed_issues: - if already_closed_issue_num in proj_issues_count: - proj_issues_count.pop(already_closed_issue_num) - - #If no project cards are found that match the issue, then exit script: - if not proj_issues_count: - endmsg = "No project cards match the issue being closed, so the script will do nothing." - end_script(endmsg) + #++++++++++++++++++++++++++++++++++++++++++++++ + #Attempt to close all referenced issues and PRs + #++++++++++++++++++++++++++++++++++++++++++++++ - #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - #Check if the number of "To-do" project cards matches the total number - #of merged PRs for each 'close' issue. - # - #Then, close all issues for which project cards equals merged PRs - # - #If not, then simply move the project card to the relevant project's - #"closed issues" column. - #+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - #Loop over project issues and counts that have been "closed" by merged PR: - for issue_num, issue_count in proj_issues_count.items(): - - #If issue count is just one, then close issue: - if issue_count == 1: - #Extract github issue object: - cam_issue = cam_repo.get_issue(number=issue_num) - #Close issue: - cam_issue.edit(state='closed') - print("Issue #{} has been closed.".format(issue_num)) - else: - #Extract card id from id dictionary: - if issue_num in proj_issue_card_ids: - card_id = proj_issue_card_ids[issue_num] - else: - #If issue isn't in dictionary, then it means the issue - #number was never found in the "To do" column, which - #likely means the user either referenced the wrong - #issue number, or the issue was never assigned to the - #project. Warn user and then exit with a non-zero - #error so that the Action fails: - endmsg = 'Issue #{} was not found in the "To Do" Column of the "{}" project.\n' \ - 'Either the wrong issue number was referenced, or the issue was never ' \ - 'attached to the project.'.format(issue_num, proj_mod_name) - print(endmsg) - sys.exit(1) - - #Then move the card on the relevant project page to the "closed issues" column: - project_card_move(token.strip(), column_target_id, card_id) - - #++++++++++++++++++++++++++++++++++++++++++++++++++++++ - #Finally, close all Pull Requests in "close_pulls" list: - #++++++++++++++++++++++++++++++++++++++++++++++++++++++ + #Loop over referenced issues: + for issue_num in close_issues: + #Extract github issue object: + cam_issue = cam_repo.get_issue(number=issue_num) + #Close issue: + cam_issue.edit(state='closed') + print(f"Issue #{issue_num} has been closed.") + #Loop over referenced PRs: for pull_num in close_pulls: #Extract Pull request object: cam_pull = cam_repo.get_pull(number=pull_num) #Close Pull Request: cam_pull.edit(state='closed') - print("Pull Request #{} has been closed.".format(pull_num)) + print(f"Pull Request #{pull_num} has been closed.") #++++++++++ #End script From 2b900aff1c0593dfb6f950ed5147aa29b9564649 Mon Sep 17 00:00:00 2001 From: Jesse Nusbaumer Date: Mon, 19 Aug 2024 13:43:48 -0600 Subject: [PATCH 69/75] Fix comment to remove CAMDEN reference. --- .github/scripts/branch_pr_issue_closer.py | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/scripts/branch_pr_issue_closer.py b/.github/scripts/branch_pr_issue_closer.py index d4c3438cad..1065ded147 100755 --- a/.github/scripts/branch_pr_issue_closer.py +++ b/.github/scripts/branch_pr_issue_closer.py @@ -100,7 +100,7 @@ def _main_prog(): ghub = Github(token) #+++++++++++++++++++++ - #Open NCAR/CAMDEN repo + #Open ESCOMP/CAM repo #+++++++++++++++++++++ cam_repo = ghub.get_repo("ESCOMP/CAM") From a642e33dcb20673abbf4f4c71dd6c449b5591e43 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Mon, 19 Aug 2024 17:55:44 -0600 Subject: [PATCH 70/75] Remove dt from call to ZM convtran --- src/physics/spcam/crmclouds_camaerosols.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/physics/spcam/crmclouds_camaerosols.F90 b/src/physics/spcam/crmclouds_camaerosols.F90 index 3d8f2e315f..43889eaeeb 100644 --- a/src/physics/spcam/crmclouds_camaerosols.F90 +++ b/src/physics/spcam/crmclouds_camaerosols.F90 @@ -739,7 +739,7 @@ subroutine crmclouds_convect_tend(state, ptend, ztodt, pbuf) ptend%lq,state%q(:ncol,:,:), pcnst, mu(:ncol,:), md(:ncol,:), & du(:ncol,:), eu(:ncol,:), ed(:ncol,:), dp(:ncol,:), dsubcld(:ncol), & jt(:ncol),maxg(:ncol),ideep(:ncol), 1, lengath, & - nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:), ztodt ) + nstep, fracis(:ncol,:,:), ptend%q(:ncol,:,:), dpdry(:ncol,:)) end subroutine crmclouds_convect_tend !===================================================================================================== From 3335f4bab13b9eb64e08ba72a43c2b71a7046c88 Mon Sep 17 00:00:00 2001 From: Cheryl Craig Date: Mon, 19 Aug 2024 17:59:40 -0600 Subject: [PATCH 71/75] ChangeLog for cam6_4_022 --- doc/ChangeLog | 176 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 176 insertions(+) diff --git a/doc/ChangeLog b/doc/ChangeLog index 6f9974c465..973ef3b4e3 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,3 +1,179 @@ + +=============================================================== + +Tag name: cam6_4_022 +Originator(s): cacraig +Date: Aug 19, 2024 +One-line Summary: Remove 0.5*timestep from call to ZM +Github PR URL: https://github.com/ESCOMP/CAM/pull/1127 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + - Remove half timestep from ZM code: https://github.com/ESCOMP/CAM/issues/1124 + +Describe any changes made to build system: N/A + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets: N/A + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume + +List all files eliminated: N/A + +List all files added and what they do: N/A + +List all existing files that have been modified, and describe the changes: +M .gitmodules +M src/atmos_phys + - Update atmos_phys tag to bring in the ZM changes from it + +M src/physics/cam/zm_conv_intr.F90 +M src/physics/spcam/crmclouds_camaerosols.F90 + - Change the CAM calls to ZM + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + +ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + +SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: FAIL) details: +SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: + - pre-existing failures -- need fix in CLM external + +SMS_D_Ln9.T42_T42.FSCAM.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure -- need fix in CICE external + + ERC_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPMOZ.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f19_f19_mg17.QPX2000.derecho_intel.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC5HIST.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9_P144x1.ne16pg3_ne16pg3_mg17.QPC6HIST.derecho_intel.cam-outfrq3s_ttrac_usecase (Overall: DIFF) details: + ERI_D_Ln18.f45_f45_mg37.QPC41850.derecho_intel.cam-co2rmp_usecase (Overall: DIFF) details: + ERP_D_Ln9.f19_f19_mg17.QPC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne30pg3_ne30pg3_mg17.FLTHIST.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_D_Ln9_P64x2.f09_f09_mg17.QSC6.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: DIFF) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERP_Ln9_P24x3.f45_f45_mg37.QPWmaC6.derecho_intel.cam-outfrq9s_mee_fluxes (Overall: DIFF) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 (Overall: DIFF) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: DIFF) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + SMS_D_Ld2.f19_f19_mg17.QPC5HIST.derecho_intel.cam-volc_usecase (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC2000climo.derecho_intel.cam-outfrq3s_usecase (Overall: DIFF) details: + SMS_D_Ln9.f19_f19_mg17.QPC5M7.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16_ne16_mg17.QPX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FCts4MTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: DIFF) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: DIFF) details: + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: DIFF) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: DIFF) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: DIFF) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + - Roundoff answer changes expected + +derecho/nvhpc/aux_cam: + ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default (Overall: DIFF) details: + - Roundoff answer changes expected + + +izumi/nag/aux_cam: +DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure - issue #670 + + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-carma_sea_salt (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_cosp (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_subcol (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_am (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_cospsathist (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPWmaC6.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + ERC_D_Ln9.ne16_ne16_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne16pg3_ne16pg3_mg17.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-outfrq3s_ttrac (Overall: DIFF) details: + ERC_D_Ln9.T5_T5_mg37.QPC4.izumi_nag.cam-outfrq3s_usecase (Overall: DIFF) details: + ERI_D_Ln18.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + ERI_D_Ln18.f19_f19_mg17.QPC6.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5_ne5_mg37.QPC5.izumi_nag.cam-ttrac_loadbal3 (Overall: DIFF) details: + SMS_D_Ln3.ne5pg3_ne5pg3_mg37.QPX2000.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + SMS_D_Ln6.ne5_ne5_mg37.QPWmaC4.izumi_nag.cam-outfrq3s_physgrid_tem (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-rad_diag_mam (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPC6.izumi_nag.cam-outfrq3s_ba (Overall: DIFF) details: + SMS_P48x1_D_Ln3.f09_f09_mg17.QPC6HIST.izumi_nag.cam-outfrq3s_co2cycle_usecase (Overall: DIFF) details: + SUB_D_Ln9.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s (Overall: DIFF) details: + TMC_D.f10_f10_mg37.QPC5.izumi_nag.cam-outfrq3s_eoyttrac (Overall: DIFF) details: + TMC_D.T5_T5_mg37.QPC5.izumi_nag.cam-ghgrmp_e8 (Overall: DIFF) details: + - Roundoff answer changes expected + +izumi/gnu/aux_cam: + ERC_D_Ln9.f10_f10_mg37.QPC4.izumi_gnu.cam-outfrq3s_diags (Overall: DIFF) details: + ERC_D_Ln9.f10_f10_mg37.QPC5.izumi_gnu.cam-rad_diag (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC4.izumi_gnu.cam-outfrq3s_nudging_ne5_L26 (Overall: DIFF) details: + ERC_D_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq3s_ba (Overall: DIFF) details: + ERI_D_Ln18.T5_T5_mg37.QPC4.izumi_gnu.cam-co2rmp (Overall: DIFF) details: + ERP_D_Ln9.C48_C48_mg17.QPC6.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + ERP_D_Ln9.ne3pg3_ne3pg3_mg37.QPC6.izumi_gnu.cam-outfrq9s_rrtmgp (Overall: DIFF) details: + ERP_Ln9.ne5_ne5_mg37.QPC5.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal0 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal1 (Overall: DIFF) details: + PLB_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-ttrac_loadbal3 (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC4.izumi_gnu.cam-scm_prep (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + SMS_D_Ln3.f10_f10_mg37.QPMOZ.izumi_gnu.cam-outfrq3s_chemproc (Overall: DIFF) details: + SMS_D_Ln9.f10_f10_mg37.QPWmaC4.izumi_gnu.cam-outfrq9s_apmee (Overall: DIFF) details: + SMS_D_Ln9.ne5pg3_ne5pg3_mg37.QPC5.izumi_gnu.cam-outfrq3s_ttrac (Overall: DIFF) details: + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: DIFF) details: + - Roundoff answer changes expected + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: All which call ZM +- what platforms/compilers: All +- nature of change (roundoff; larger than roundoff but same climate; new + climate): roundoff + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + - Conclusion reached by Adam Harrington - See issue for testing details + +=============================================================== =============================================================== Tag name: cam6_4_021 From 54a0ba9f083604f8a1a4ad8618f89c61b374e211 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Thu, 22 Aug 2024 16:58:37 -0600 Subject: [PATCH 72/75] update cice and cdeps for regression failures,Changelog for PR,scam to use coldstart, restore ne30 defaults in pes configure --- .gitmodules | 4 +- cime_config/config_pes.xml | 37 +++ cime_config/testdefs/testlist_cam.xml | 8 +- .../scam_mandatory/shell_commands | 4 +- doc/ChangeLog | 297 ++++++++++++++++++ 5 files changed, 342 insertions(+), 8 deletions(-) diff --git a/.gitmodules b/.gitmodules index 418d917c26..d8a34d6ce1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -151,7 +151,7 @@ fxDONOTUSEurl = https://github.com/ESCOMP/CMEPS.git [submodule "cdeps"] path = components/cdeps url = https://github.com/ESCOMP/CDEPS.git -fxtag = cdeps1.0.45 +fxtag = cdeps1.0.48 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESCOMP/CDEPS.git @@ -172,7 +172,7 @@ fxDONOTUSEurl = https://github.com/NCAR/ParallelIO [submodule "cice"] path = components/cice url = https://github.com/ESCOMP/CESM_CICE -fxtag = cesm_cice6_5_0_10 +fxtag = cesm_cice6_5_0_12 fxrequired = ToplevelRequired fxDONOTUSEurl = https://github.com/ESCOMP/CESM_CICE diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index 5c8df356e4..7b50ec52f3 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -112,6 +112,43 @@ + + + + none + + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 665d65fb15..8c4260275a 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1165,7 +1165,7 @@ - + @@ -1358,7 +1358,7 @@ - + @@ -1474,7 +1474,7 @@ - + @@ -1484,7 +1484,7 @@ - + diff --git a/cime_config/usermods_dirs/scam_mandatory/shell_commands b/cime_config/usermods_dirs/scam_mandatory/shell_commands index cfc2114554..4fa8390aa5 100755 --- a/cime_config/usermods_dirs/scam_mandatory/shell_commands +++ b/cime_config/usermods_dirs/scam_mandatory/shell_commands @@ -9,7 +9,7 @@ ./xmlchange REST_OPTION=never # Note that clm cannot use initial conditions with SCAM -so will only use specified phenology -# Only change if CLM_FORCE_COLDSTART exists and dycore is eulerian -if [ `./xmlquery --value CAM_DYCORE` == 'eul' ] && [ `./xmlquery --value CLM_FORCE_COLDSTART |& grep -c 'ERROR'` -eq 0 ]; then +# Only change if CLM_FORCE_COLDSTART exists. +if [ `./xmlquery --value CLM_FORCE_COLDSTART 2>&1 | grep -c 'ERROR'` -eq 0 ]; then ./xmlchange CLM_FORCE_COLDSTART='on' fi diff --git a/doc/ChangeLog b/doc/ChangeLog index 973ef3b4e3..54d09896a0 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -1,4 +1,301 @@ +=============================================================== + +Tag name: cam6_4_023 +Originator(s): jet +Date: Aug 22, 2024 +One-line Summary: cam6_4_023: SCAM-SE feature addition plus bugfixes and some refactoring +Github PR URL: https://github.com/ESCOMP/CAM/pull/958 + +Purpose of changes (include the issue number and title text for each relevant GitHub issue): + +This update includes some refactoring of SCAM, a few bugfixes, and adding the capability to use +spectral elements dycore to do vertical transport in the column. The SE feature addition follows +the E3SM implementation where a complete coarse resolution (ne3np4) of the SE dycore is initialized +but only a single element is run through vertical transport. The single column chosen by scmlat, scmlon. + +Like the Eulerian version, SCAM-SE also has a bit for bit test to validate an exact run through +the same physics as the full 3d model. Because SCAM updates the solution using a slightly different +order of operations, the bfb capability is tested by making a special diagnostic run of CAM where +the 3d model derives the phys/dyn tendency each time step and then recalculates the prognostic +solution using the derived tendencies and SCAM's prognostic equation. This new solution (which is +less precise (roundoff) due to the change in order of operations) is substituted for the full 3d +solution at each time step of the model run. The substitution of the roundoff state in the 3d run +allows SCAM to reproduce (BFB) each time step using the captured tendencies in the cam iop history file. + +The SCAM-SE vertical advection skips the horizontal step and derives the floating level tendency +based on the IOP prescribed vertical velocity. The floating levels are subsequently remapped at +the end of the vertically Lagrangian dynamics step. + +Describe any changes made to build system: Allow SCAM to be built with spectral element dycore + +Describe any changes made to the namelist: N/A + +List any changes to the defaults for the boundary datasets:New boundary data for SE SCM +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-09-01-00000.nc +A atm/cam/inic/se/cami_0000-01-01_ne3np4_L30_c120315.nc +A atm/cam/inic/se/cami_0000-01-01_ne3np4_L26_c120525.nc +A atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc +A atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc +A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc +A atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc + +Describe any substantial timing or memory changes: N/A + +Code reviewed by: nusbaume, cacraig + +List all files eliminated: + + D bld/namelist_files/use_cases/scam_arm95.xml + D bld/namelist_files/use_cases/scam_arm97.xml + D bld/namelist_files/use_cases/scam_gateIII.xml + D bld/namelist_files/use_cases/scam_mpace.xml + D bld/namelist_files/use_cases/scam_sparticus.xml + D bld/namelist_files/use_cases/scam_togaII.xml + D bld/namelist_files/use_cases/scam_twp06.xml + - These are now available via xml defaults + D cime_config/usermods_dirs/scam_arm95/shell_commands + D cime_config/usermods_dirs/scam_arm95/user_nl_cam + D cime_config/usermods_dirs/scam_arm97/shell_commands + D cime_config/usermods_dirs/scam_arm97/user_nl_cam + D cime_config/usermods_dirs/scam_atex/shell_commands + D cime_config/usermods_dirs/scam_atex/user_nl_cam + D cime_config/usermods_dirs/scam_bomex/user_nl_cam + D cime_config/usermods_dirs/scam_cgilsS11/shell_commands + D cime_config/usermods_dirs/scam_cgilsS11/user_nl_cam + D cime_config/usermods_dirs/scam_cgilsS12/shell_commands + D cime_config/usermods_dirs/scam_cgilsS12/user_nl_cam + D cime_config/usermods_dirs/scam_cgilsS6/shell_commands + D cime_config/usermods_dirs/scam_cgilsS6/user_nl_cam + D cime_config/usermods_dirs/scam_dycomsRF01/shell_commands + D cime_config/usermods_dirs/scam_dycomsRF01/user_nl_cam + D cime_config/usermods_dirs/scam_dycomsRF02/shell_commands + D cime_config/usermods_dirs/scam_dycomsRF02/user_nl_cam + D cime_config/usermods_dirs/scam_gateIII/shell_commands + D cime_config/usermods_dirs/scam_gateIII/user_nl_cam + D cime_config/usermods_dirs/scam_micre2017/shell_commands + D cime_config/usermods_dirs/scam_micre2017/user_nl_cam + D cime_config/usermods_dirs/scam_mpace/shell_commands + D cime_config/usermods_dirs/scam_mpace/user_nl_cam + D cime_config/usermods_dirs/scam_rico/shell_commands + D cime_config/usermods_dirs/scam_rico/user_nl_cam + D cime_config/usermods_dirs/scam_SAS/shell_commands + D cime_config/usermods_dirs/scam_SAS/user_nl_cam + D cime_config/usermods_dirs/scam_sparticus/shell_commands + D cime_config/usermods_dirs/scam_sparticus/user_nl_cam + D cime_config/usermods_dirs/scam_togaII/shell_commands + D cime_config/usermods_dirs/scam_togaII/user_nl_cam + D cime_config/usermods_dirs/scam_twp06/shell_commands + D cime_config/usermods_dirs/scam_twp06/user_nl_cam + D src/control/history_defaults.F90 + - after moving scam specific code there was nothing left here + + +List all files added and what they do: N/A + A cime_config/usermods_dirs/scam_camfrc/shell_commands + A cime_config/usermods_dirs/scam_camfrc/user_nl_cam + A cime_config/usermods_dirs/scam_mandatory/shell_commands + - template directories for usermods to scam. + + A src/dynamics/se/apply_iop_forcing.F90 + A src/dynamics/se/dycore/se_single_column_mod.F90 + A src/utils/hybvcoord_mod.F90 + - enable iop forcing for SE SCM + +List all existing files that have been modified, and describe the changes: +M .gitmodules + - update cice to fix scam failure + - update cdeps to fix CDEPS regression test build failures +M bld/build-namelist + - update namelist defaults for scm relaxation. +M bld/config_files/definition.xml + - new configurations option for scam_iops +M bld/configure + - new configure options for SCAM refactor +M bld/namelist_files/namelist_defaults_cam.xml +M bld/namelist_files/namelist_definition.xml + - new configurations option for scam_iops +M cime_config/buildcpp + - setup new build for se SCAM test +M cime_config/config_component.xml +M cime_config/config_compsets.xml + - add scam defaults to cime +M cime_config/config_pes.xml + - add scam se pe defaults +M cime_config/SystemTests/sct.py + - setup new BFB se SCAM test +M cime_config/testdefs/testlist_cam.xml +M cime_config/testdefs/testmods_dirs/cam/scmarm/shell_commands + - add new scam se regression tests +M cime_config/usermods_dirs/scam_mandatory/shell_commands + - add warmstart logic +M src/control/cam_comp.F90 + - cleanup some of the BFB_CAM_SCAM_IOP cppdefs +M src/control/cam_history.F90 + - set write_camiop logical if CAMIOP history type is requested by user. +M src/control/getinterpnetcdfdata.F90 +M src/control/history_scam.F90 + - generalize for output on single column grid +M src/control/ncdio_atm.F90 + - add physgrid_scm, scam uses the full physgrid to read data from boundary and +M src/control/scamMod.F90 + - new control parameters for SCAM-SE +M src/dynamics/eul/diag_dynvar_ic.F90 +M src/dynamics/eul/dyn_comp.F90 +M src/dynamics/eul/dynpkg.F90 + - remove more scam CPP defines +M src/dynamics/eul/dyn_grid.F90 +M src/dynamics/eul/iop.F90 + - generalize to use common routines for SE and EUL +M src/dynamics/eul/restart_dynamics.F90 + - remove more scam CPP defines +M src/dynamics/eul/scmforecast.F90 +M src/dynamics/eul/stepon.F90 +M src/dynamics/eul/tfilt_massfix.F90 + - refactor/cleanup +M src/dynamics/se/advect_tend.F90 + - capture SE advective tendencies for BFB testing +M src/dynamics/se/dp_coupling.F90 + - phys/dyn interface additions for SE-SCAM +M src/dynamics/se/dycore/prim_advance_mod.F90 +M src/dynamics/se/dycore/prim_driver_mod.F90 +M src/dynamics/se/dycore/vertremap_mod.F90 +M src/dynamics/se/dycore/viscosity_mod.F90 + - refactor/cleanup +M src/dynamics/se/dyn_comp.F90 +M src/dynamics/se/dyn_grid.F90 + - add SE single column mod +M src/dynamics/se/gravity_waves_sources.F90 + - hvcoord +M src/dynamics/se/stepon.F90 + - add SE SCAM iop update calls +M src/infrastructure/phys_grid.F90 + - update for single column phys grid +M src/physics/cam7/physpkg.F90 +M src/physics/cam/cam_diagnostics.F90 + - clean up BFB cpp defs +M src/physics/cam/check_energy.F90 + - add heat_glob for SE iop +M src/physics/cam/chem_surfvals.F90 + - add column initialization for greenhouse gasses +M src/physics/cam/clubb_intr.F90 + - use model grid box size not arbitrary SCM column size +M src/physics/cam/convect_shallow.F90 + - add DQP diagnostic +M src/physics/cam/phys_grid.F90 + - define scm single column grid for scm history +M src/physics/cam/physpkg.F90 + - clean up BFB cpp defs +M src/utils/cam_grid_support.F90 + - add trim to grid name +M src/utils/hycoef.F90 + - add hvcoord struct + + +If there were any failures reported from running test_driver.sh on any test +platform, and checkin with these failures has been OK'd by the gatekeeper, +then copy the lines from the td.*.status files for the failed tests to the +appropriate machine below. All failed tests must be justified. + +derecho/intel/aux_cam: + + ERP_Ln9.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - pre-existing failure due to HEMCO not having reproducible results issues #1018 and #856 + SMS_D_Ln9_P1280x1.ne0ARCTICne30x4_ne0ARCTICne30x4_mt12.FHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: + SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: + - pre-existing pend/failures -- need fix in CLM external + + SCT_D_Ln7.ne3_ne3_mg37.QPC5.derecho_intel.cam-scm_prep (Overall: FAIL) + - New Test; Failure expected (SCAM on spectral element grid) + + SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + - New Test; Failure expected; FSCAM compset named changed to FSCAMARM97 + + SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s (Overall: FAIL) + - New Test name; Failure expected (FSCAM->FSCAMARM97) + + SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: + - Roundoff answer changes expected to existing SCAM prep cases + + SMS_Lm13.f10_f10_mg37.F2000climo.derecho_intel.cam-outfrq1m (Overall: DIFF) details: + - Expected differenc due to cice update, only 2 fields different as new cice has annual restarts off. + + ERP_Ld3.f09_f09_mg17.FWHIST.derecho_intel.cam-reduced_hist1d (Overall: NLFAIL) details: + ERP_Lh12.f19_f19_mg17.FW4madSD.derecho_intel.cam-outfrq3h (Overall: NLFAIL) details: + ERP_Ln9.C96_C96_mg17.F2000climo.derecho_intel.cam-outfrq9s_mg3 (Overall: NLFAIL) details: + ERP_Ln9.f09_f09_mg17.F1850.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.f09_f09_mg17.F2000climo.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.f09_f09_mg17.FHIST_BDRD.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.f19_f19_mg17.FWsc1850.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FCnudged.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERP_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERS_Ld3.f10_f10_mg37.F1850.derecho_intel.cam-outfrq1d_14dec_ghg_cam7 (Overall: NLFAIL) details: + ERS_Ln9.f09_f09_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERS_Ln9.f19_f19_mg17.FSPCAMS.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERS_Ln9.f19_f19_mg17.FXSD.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + ERS_Ln9_P288x1.mpasa120_mpasa120.F2000climo.derecho_intel.cam-outfrq9s_mpasa120 (Overall: NLFAIL) details: + ERS_Ln9_P36x1.mpasa480_mpasa480.F2000climo.derecho_intel.cam-outfrq9s_mpasa480 (Overall: NLFAIL) details: + SMS_D_Ln9.f09_f09_mg17.FCts2nudged.derecho_intel.cam-outfrq9s_leapday (Overall: NLFAIL) details: + SMS_D_Ln9.f09_f09_mg17.FCvbsxHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9.f09_f09_mg17.FSD.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9.f19_f19_mg17.FWma2000climo.derecho_intel.cam-outfrq9s_waccm_ma_mam4 (Overall: NLFAIL) details: + SMS_D_Ln9.f19_f19_mg17.FXHIST.derecho_intel.cam-outfrq9s_amie (Overall: NLFAIL) details: + SMS_D_Ln9.ne16pg3_ne16pg3_mg17.FX2000.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FCts4MTHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9.ne30pg3_ne30pg3_mg17.FMTHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_D_Ln9_P1280x1.ne30pg3_ne30pg3_mg17.FCLTHIST.derecho_intel.cam-outfrq9s (Overall: NLFAIL) details: + SMS_Ld1.f09_f09_mg17.FCHIST_GC.derecho_intel.cam-outfrq1d (Overall: NLFAIL) details: + SMS_Ld1.f09_f09_mg17.FW2000climo.derecho_intel.cam-outfrq1d (Overall: NLFAIL) details: + SMS_Ld1.ne30pg3_ne30pg3_mg17.FC2010climo.derecho_intel.cam-outfrq1d (Overall: NLFAIL) details: + SMS_Lh12.f09_f09_mg17.FCSD_HCO.derecho_intel.cam-outfrq3h (Overall: NLFAIL) details: + SMS_Ln9.f09_f09_mg17.F2010climo.derecho_intel.cam-nudging (Overall: NLFAIL) details: + SMS_Ln9.f09_f09_mg17.FW1850.derecho_intel.cam-reduced_hist3s (Overall: NLFAIL) details: + SMS_Ln9.f19_f19.F2000climo.derecho_intel.cam-silhs (Overall: NLFAIL) details: + SMS_Ln9.f19_f19_mg17.FHIST.derecho_intel.cam-outfrq9s_nochem (Overall: NLFAIL) details: + SMS_Ln9.ne30pg3_ne30pg3_mg17.FW2000climo.derecho_intel.cam-outfrq9s_rrtmgp (Overall: NLFAIL) details + - Expected failures, In addition to differences these tests also failed namelist comparisons due to the updated cice + +derecho/nvhpc/aux_cam: + ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default (Overall: DIFF) details: + - Roundoff answer changes expected + +izumi/nag/aux_cam: + DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: + - pre-existing failure - issue #670 + SMS_D_Ln7.T42_T42_mg17.QPSCAMC5.izumi_nag.cam-scmarm (Overall: DIFF) details: + - Roundoff answer changes expected to existing SCAM cases + +izumi/gnu/aux_cam: + SCT_D_Ln7.ne3_ne3_mg37.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: FAIL) + - New Test Failure expected. + SCT_D_Ln7.T42_T42_mg17.QPC4.izumi_gnu.cam-scm_prep (Overall: DIFF) details: + SCT_D_Ln7.T42_T42_mg17.QPC6.izumi_gnu.cam-scm_prep_c6 (Overall: DIFF) details: + - Roundoff answer changes expected to existing SCAM cases + SMS_P48x1_D_Ln9.f19_f19_mg17.FW4madSD.izumi_gnu.cam-outfrq9s (Overall: NLFAIL) details: + - Expected namelist failure due to cice update. + +CAM tag used for the baseline comparison tests if different than previous +tag: + +Summarize any changes to answers, i.e., +- what code configurations: SCAM tests +- what platforms/compilers: All +- nature of change (roundoff; larger than roundoff but same climate; new + climate): new climate - larger changes confined to top levels that were ignored in previous versions. + +If bitwise differences were observed, how did you show they were no worse +than roundoff? + +=============================================================== =============================================================== Tag name: cam6_4_022 From b88c67e0904b8a56759125c732ba25513aaf48d5 Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Fri, 23 Aug 2024 10:44:46 -0600 Subject: [PATCH 73/75] need scam_mandatory to set COLDSTART until CLM scam mods tagged --- cime_config/config_component.xml | 1 + 1 file changed, 1 insertion(+) diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 39b94cb587..6d652e8e03 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -377,6 +377,7 @@ $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/aquap $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/aquap + $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/scam_mandatory $COMP_ROOT_DIR_ATM/cime_config/usermods_dirs/scam_camfrc run_component_cam From 40f6c5c5d2e15624ae9d44bec609beefd33d7dae Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Sun, 25 Aug 2024 17:21:31 -0600 Subject: [PATCH 74/75] update mpace regression test and ChangeLog --- cime_config/testdefs/testlist_cam.xml | 8 +++++- .../cam/scam_mpace_outfrq9s/include_user_mods | 1 - .../cam/scam_mpace_outfrq9s/shell_commands | 2 -- .../cam/scam_mpace_outfrq9s/user_nl_cam | 4 --- .../cam/scam_mpace_outfrq9s/user_nl_clm | 27 ------------------- .../cam/scam_mpace_outfrq9s/user_nl_cpl | 2 -- doc/ChangeLog | 10 ++++++- 7 files changed, 16 insertions(+), 38 deletions(-) delete mode 100644 cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/include_user_mods delete mode 100644 cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/shell_commands delete mode 100644 cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cam delete mode 100644 cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_clm delete mode 100644 cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cpl diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 8c4260275a..68a0ddbac3 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1159,6 +1159,7 @@ + @@ -1168,6 +1169,7 @@ + @@ -1178,6 +1180,7 @@ + @@ -1197,6 +1200,7 @@ + @@ -1361,6 +1365,7 @@ + @@ -1371,6 +1376,7 @@ + @@ -1484,7 +1490,7 @@ - + diff --git a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/include_user_mods b/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/include_user_mods deleted file mode 100644 index 4b0f7f1abb..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/include_user_mods +++ /dev/null @@ -1 +0,0 @@ -../../../../usermods_dirs/scam_mpace diff --git a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/shell_commands b/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/shell_commands deleted file mode 100644 index eb40ad83e0..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/shell_commands +++ /dev/null @@ -1,2 +0,0 @@ -./xmlchange ROF_NCPL=\$ATM_NCPL -./xmlchange GLC_NCPL=\$ATM_NCPL diff --git a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cam deleted file mode 100644 index 8482082dce..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cam +++ /dev/null @@ -1,4 +0,0 @@ -mfilt=1,1,1,1,1,1 -ndens=1,1,1,1,1,1 -nhtfrq=9,9,9,9,9,9 -inithist='ENDOFRUN' diff --git a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_clm deleted file mode 100644 index 0d83b5367b..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_clm +++ /dev/null @@ -1,27 +0,0 @@ -!---------------------------------------------------------------------------------- -! Users should add all user specific namelist changes below in the form of -! namelist_var = new_namelist_value -! -! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options -! are set in the CLM_NAMELIST_OPTS env variable. -! -! EXCEPTIONS: -! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting -! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting -! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting -! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting -! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting -! Set irrigate by the CLM_BLDNML_OPTS -irrig setting -! Set dtime with L_NCPL option -! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options -! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases -! (includes $inst_string for multi-ensemble cases) -! Set glc_grid with CISM_GRID option -! Set glc_smb with GLC_SMB option -! Set maxpatch_glcmec with GLC_NEC option -! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable -!---------------------------------------------------------------------------------- -hist_nhtfrq = 9 -hist_mfilt = 1 -hist_ndens = 1 - diff --git a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cpl b/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cpl deleted file mode 100644 index 398535cf65..0000000000 --- a/cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cpl +++ /dev/null @@ -1,2 +0,0 @@ -reprosum_diffmax=1.0e-14 -reprosum_recompute=.true. diff --git a/doc/ChangeLog b/doc/ChangeLog index 54d09896a0..6b34982070 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ Tag name: cam6_4_023 Originator(s): jet -Date: Aug 22, 2024 +Date: Aug 23, 2024 One-line Summary: cam6_4_023: SCAM-SE feature addition plus bugfixes and some refactoring Github PR URL: https://github.com/ESCOMP/CAM/pull/958 @@ -93,6 +93,13 @@ List all files eliminated: D cime_config/usermods_dirs/scam_togaII/user_nl_cam D cime_config/usermods_dirs/scam_twp06/shell_commands D cime_config/usermods_dirs/scam_twp06/user_nl_cam + - replace by xml defaults + D cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/include_user_mods + D cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/shell_commands + D cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cam + D cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_clm + D cime_config/testdefs/testmods_dirs/cam/scam_mpace_outfrq9s/user_nl_cpl + - no longer valid for mpace setup D src/control/history_defaults.F90 - after moving scam specific code there was nothing left here @@ -131,6 +138,7 @@ M cime_config/config_pes.xml M cime_config/SystemTests/sct.py - setup new BFB se SCAM test M cime_config/testdefs/testlist_cam.xml + - fix mpace test and add test_scam category M cime_config/testdefs/testmods_dirs/cam/scmarm/shell_commands - add new scam se regression tests M cime_config/usermods_dirs/scam_mandatory/shell_commands From c50362cbfcffaf36096181d7a6b6da3a9d310a7c Mon Sep 17 00:00:00 2001 From: John Truesdale Date: Mon, 26 Aug 2024 07:31:12 -0600 Subject: [PATCH 75/75] update ChangeLog, pull hvcoord addition --- doc/ChangeLog | 146 +++++++++++----------- src/control/scamMod.F90 | 85 ++++++------- src/dynamics/eul/dyn_comp.F90 | 4 +- src/dynamics/eul/dyn_grid.F90 | 13 -- src/dynamics/eul/stepon.F90 | 4 +- src/dynamics/se/apply_iop_forcing.F90 | 4 +- src/dynamics/se/dyn_comp.F90 | 7 +- src/dynamics/se/dyn_grid.F90 | 15 ++- src/dynamics/se/gravity_waves_sources.F90 | 2 +- src/dynamics/se/se_single_column_mod.F90 | 4 +- src/dynamics/se/stepon.F90 | 8 +- src/utils/hybvcoord_mod.F90 | 28 ----- src/utils/hycoef.F90 | 11 -- 13 files changed, 147 insertions(+), 184 deletions(-) delete mode 100644 src/utils/hybvcoord_mod.F90 diff --git a/doc/ChangeLog b/doc/ChangeLog index 6b34982070..31167ed661 100644 --- a/doc/ChangeLog +++ b/doc/ChangeLog @@ -2,7 +2,7 @@ Tag name: cam6_4_023 Originator(s): jet -Date: Aug 23, 2024 +Date: Aug 26, 2024 One-line Summary: cam6_4_023: SCAM-SE feature addition plus bugfixes and some refactoring Github PR URL: https://github.com/ESCOMP/CAM/pull/958 @@ -26,25 +26,29 @@ The SCAM-SE vertical advection skips the horizontal step and derives the floatin based on the IOP prescribed vertical velocity. The floating levels are subsequently remapped at the end of the vertically Lagrangian dynamics step. +Closes Issue SCAM-SE - Allow use of spectral elements dycore in single column mode. #957 +Closes Issue some SCAM IOP's are broken #853 +Closes Issue Unhelpful error message when running SCAM and IOP file is too short #742 + Describe any changes made to build system: Allow SCAM to be built with spectral element dycore Describe any changes made to the namelist: N/A List any changes to the defaults for the boundary datasets:New boundary data for SE SCM -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-09-01-00000.nc -A atm/cam/inic/se/cami_0000-01-01_ne3np4_L30_c120315.nc -A atm/cam/inic/se/cami_0000-01-01_ne3np4_L26_c120525.nc -A atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc -A atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc -A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc -A atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-09-01-00000.nc + A atm/cam/inic/se/cami_0000-01-01_ne3np4_L30_c120315.nc + A atm/cam/inic/se/cami_0000-01-01_ne3np4_L26_c120525.nc + A atm/cam/topo/se/ne3np4_gmted2010_modis_bedmachine_nc0540_Laplace1000_noleak_20230717.nc + A atm/cam/chem/trop_mam/atmsrf_ne3np4_230718.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-01-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-02-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-04-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-06-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-07-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-08-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-10-01-00000.nc + A atm/cam/inic/se/CESM2.F2000climo.ne3np4.cam.i.0003-12-01-00000.nc + A atm/cam/scam/iop/micre2017_3mo.cam.i.2017-01-01-00000.regrid.ne3np4.nc Describe any substantial timing or memory changes: N/A @@ -112,97 +116,96 @@ List all files added and what they do: N/A A src/dynamics/se/apply_iop_forcing.F90 A src/dynamics/se/dycore/se_single_column_mod.F90 - A src/utils/hybvcoord_mod.F90 - enable iop forcing for SE SCM List all existing files that have been modified, and describe the changes: -M .gitmodules + M .gitmodules - update cice to fix scam failure - update cdeps to fix CDEPS regression test build failures -M bld/build-namelist + M bld/build-namelist - update namelist defaults for scm relaxation. -M bld/config_files/definition.xml + M bld/config_files/definition.xml - new configurations option for scam_iops -M bld/configure + M bld/configure - new configure options for SCAM refactor -M bld/namelist_files/namelist_defaults_cam.xml -M bld/namelist_files/namelist_definition.xml + M bld/namelist_files/namelist_defaults_cam.xml + M bld/namelist_files/namelist_definition.xml - new configurations option for scam_iops -M cime_config/buildcpp + M cime_config/buildcpp - setup new build for se SCAM test -M cime_config/config_component.xml -M cime_config/config_compsets.xml + M cime_config/config_component.xml + M cime_config/config_compsets.xml - add scam defaults to cime -M cime_config/config_pes.xml + M cime_config/config_pes.xml - add scam se pe defaults -M cime_config/SystemTests/sct.py + M cime_config/SystemTests/sct.py - setup new BFB se SCAM test -M cime_config/testdefs/testlist_cam.xml + M cime_config/testdefs/testlist_cam.xml - fix mpace test and add test_scam category -M cime_config/testdefs/testmods_dirs/cam/scmarm/shell_commands + M cime_config/testdefs/testmods_dirs/cam/scmarm/shell_commands - add new scam se regression tests -M cime_config/usermods_dirs/scam_mandatory/shell_commands + M cime_config/usermods_dirs/scam_mandatory/shell_commands - add warmstart logic -M src/control/cam_comp.F90 + M src/control/cam_comp.F90 - cleanup some of the BFB_CAM_SCAM_IOP cppdefs -M src/control/cam_history.F90 + M src/control/cam_history.F90 - set write_camiop logical if CAMIOP history type is requested by user. -M src/control/getinterpnetcdfdata.F90 -M src/control/history_scam.F90 + M src/control/getinterpnetcdfdata.F90 + M src/control/history_scam.F90 - generalize for output on single column grid -M src/control/ncdio_atm.F90 + M src/control/ncdio_atm.F90 - add physgrid_scm, scam uses the full physgrid to read data from boundary and -M src/control/scamMod.F90 + M src/control/scamMod.F90 - new control parameters for SCAM-SE -M src/dynamics/eul/diag_dynvar_ic.F90 -M src/dynamics/eul/dyn_comp.F90 -M src/dynamics/eul/dynpkg.F90 + M src/dynamics/eul/diag_dynvar_ic.F90 + M src/dynamics/eul/dyn_comp.F90 + M src/dynamics/eul/dynpkg.F90 - remove more scam CPP defines -M src/dynamics/eul/dyn_grid.F90 -M src/dynamics/eul/iop.F90 + M src/dynamics/eul/dyn_grid.F90 + M src/dynamics/eul/iop.F90 - generalize to use common routines for SE and EUL -M src/dynamics/eul/restart_dynamics.F90 + M src/dynamics/eul/restart_dynamics.F90 - remove more scam CPP defines -M src/dynamics/eul/scmforecast.F90 -M src/dynamics/eul/stepon.F90 -M src/dynamics/eul/tfilt_massfix.F90 + M src/dynamics/eul/scmforecast.F90 + M src/dynamics/eul/stepon.F90 + M src/dynamics/eul/tfilt_massfix.F90 - refactor/cleanup -M src/dynamics/se/advect_tend.F90 + M src/dynamics/se/advect_tend.F90 - capture SE advective tendencies for BFB testing -M src/dynamics/se/dp_coupling.F90 + M src/dynamics/se/dp_coupling.F90 - phys/dyn interface additions for SE-SCAM -M src/dynamics/se/dycore/prim_advance_mod.F90 -M src/dynamics/se/dycore/prim_driver_mod.F90 -M src/dynamics/se/dycore/vertremap_mod.F90 -M src/dynamics/se/dycore/viscosity_mod.F90 + M src/dynamics/se/dycore/prim_advance_mod.F90 + M src/dynamics/se/dycore/prim_driver_mod.F90 + M src/dynamics/se/dycore/vertremap_mod.F90 + M src/dynamics/se/dycore/viscosity_mod.F90 - refactor/cleanup -M src/dynamics/se/dyn_comp.F90 -M src/dynamics/se/dyn_grid.F90 + M src/dynamics/se/dyn_comp.F90 + M src/dynamics/se/dyn_grid.F90 - add SE single column mod -M src/dynamics/se/gravity_waves_sources.F90 + M src/dynamics/se/gravity_waves_sources.F90 - hvcoord -M src/dynamics/se/stepon.F90 + M src/dynamics/se/stepon.F90 - add SE SCAM iop update calls -M src/infrastructure/phys_grid.F90 + M src/infrastructure/phys_grid.F90 - update for single column phys grid -M src/physics/cam7/physpkg.F90 -M src/physics/cam/cam_diagnostics.F90 + M src/physics/cam7/physpkg.F90 + M src/physics/cam/cam_diagnostics.F90 - clean up BFB cpp defs -M src/physics/cam/check_energy.F90 + M src/physics/cam/check_energy.F90 - add heat_glob for SE iop -M src/physics/cam/chem_surfvals.F90 + M src/physics/cam/chem_surfvals.F90 - add column initialization for greenhouse gasses -M src/physics/cam/clubb_intr.F90 + M src/physics/cam/clubb_intr.F90 - use model grid box size not arbitrary SCM column size -M src/physics/cam/convect_shallow.F90 + M src/physics/cam/convect_shallow.F90 - add DQP diagnostic -M src/physics/cam/phys_grid.F90 + M src/physics/cam/phys_grid.F90 - define scm single column grid for scm history -M src/physics/cam/physpkg.F90 + M src/physics/cam/physpkg.F90 - clean up BFB cpp defs -M src/utils/cam_grid_support.F90 + M src/utils/cam_grid_support.F90 - add trim to grid name -M src/utils/hycoef.F90 + M src/utils/hycoef.F90 - add hvcoord struct @@ -220,15 +223,12 @@ derecho/intel/aux_cam: SMS_D_Ln9_P1280x1.ne0CONUSne30x8_ne0CONUSne30x8_mt12.FCHIST.derecho_intel.cam-outfrq9s (Overall: PEND) details: - pre-existing pend/failures -- need fix in CLM external - SCT_D_Ln7.ne3_ne3_mg37.QPC5.derecho_intel.cam-scm_prep (Overall: FAIL) + SCT_D_Ln7.ne3_ne3_mg37.QPC5.derecho_intel.cam-scm_prep BFAIL - New Test; Failure expected (SCAM on spectral element grid) - SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s (Overall: FAIL) details: + SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s BFAIL - New Test; Failure expected; FSCAM compset named changed to FSCAMARM97 - SMS_D_Ln9.T42_T42.FSCAMARM97.derecho_intel.cam-outfrq9s (Overall: FAIL) - - New Test name; Failure expected (FSCAM->FSCAMARM97) - SCT_D_Ln7.T42_T42_mg17.QPC5.derecho_intel.cam-scm_prep (Overall: DIFF) details: - Roundoff answer changes expected to existing SCAM prep cases @@ -273,8 +273,8 @@ derecho/intel/aux_cam: - Expected failures, In addition to differences these tests also failed namelist comparisons due to the updated cice derecho/nvhpc/aux_cam: - ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default (Overall: DIFF) details: - - Roundoff answer changes expected + ERS_Ln9_G4-a100-openacc.ne30pg3_ne30pg3_mg17.F2000dev.derecho_nvhpc.cam-outfrq9s_mg3_default (Overall: NLFAIL) + - Expected failures due to the updated cice izumi/nag/aux_cam: DAE.f45_f45_mg37.FHS94.izumi_nag.cam-dae (Overall: FAIL) details: diff --git a/src/control/scamMod.F90 b/src/control/scamMod.F90 index 425c7412e9..e26a2e63b9 100644 --- a/src/control/scamMod.F90 +++ b/src/control/scamMod.F90 @@ -388,8 +388,7 @@ subroutine scam_readnl(nlfile,single_column_in,scmlat_in,scmlon_in) end if end subroutine scam_readnl - -subroutine readiopdata(hvcoord) +subroutine readiopdata(hyam, hybm, hyai, hybi, ps0) !----------------------------------------------------------------------- ! ! Open and read netCDF file containing initial IOP conditions @@ -399,7 +398,6 @@ subroutine readiopdata(hvcoord) ! Written by J. Truesdale August, 1996, revised January, 1998 ! !----------------------------------------------------------------------- - use hybvcoord_mod, only: hvcoord_t use getinterpnetcdfdata, only: getinterpncdata use string_utils, only: to_lower use wrap_nf, only: wrap_inq_dimid,wrap_get_vara_realx @@ -410,7 +408,7 @@ subroutine readiopdata(hvcoord) ! !------------------------------Input Arguments-------------------------- ! -type (hvcoord_t), intent(in) :: hvcoord + real(r8),intent(in) :: hyam(plev),hybm(plev),hyai(plevp),hybi(plevp),ps0 ! !------------------------------Locals----------------------------------- ! @@ -430,7 +428,8 @@ subroutine readiopdata(hvcoord) logical :: have_cnst(pcnst) real(r8) :: dummy real(r8) :: srf(1) ! value at surface - real(r8) :: hyam(plev),hybm(plev) + real(r8) :: hyamiop(plev) ! a hybrid coef midpoint + real(r8) :: hybmiop(plev) ! b hybrid coef midpoint real(r8) :: pmid(plev) ! pressure at model levels (time n) real(r8) :: pint(plevp) ! pressure at model interfaces (n ) real(r8) :: pdel(plev) ! pdel(k) = pint (k+1)-pint (k) @@ -550,11 +549,11 @@ subroutine readiopdata(hvcoord) status = nf90_inq_varid( ncid, 'hyam', varid ) if ( status == nf90_noerr .and. have_ps) then call get_start_count(ncid, varid, scmlat, scmlon, ioptimeidx, strt4, cnt4) - status = nf90_get_var(ncid, varid, hyam, strt4) + status = nf90_get_var(ncid, varid, hyamiop, strt4) status = nf90_inq_varid( ncid, 'hybm', varid ) - status = nf90_get_var(ncid, varid, hybm, strt4) + status = nf90_get_var(ncid, varid, hybmiop, strt4) do i = 1, nlev - dplevs( i ) = 1000.0_r8 * hyam( i ) + psobs * hybm( i ) / 100.0_r8 + dplevs( i ) = 1000.0_r8 * hyamiop( i ) + psobs * hybmiop( i ) / 100.0_r8 end do endif @@ -643,11 +642,11 @@ subroutine readiopdata(hvcoord) if ( use_camiop ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'t', have_tsair, & tsair(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm,tobs, status ) + dplevs, nlev,psobs, hyam, hybm,tobs, status ) else call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx,'T', have_tsair, & tsair(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tobs, status ) + dplevs, nlev,psobs, hyam, hybm, tobs, status ) endif if ( status /= nf90_noerr ) then have_t = .false. @@ -695,7 +694,7 @@ subroutine readiopdata(hvcoord) qobs(:)= 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'q', have_srf, & srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, qobs, status ) + dplevs, nlev,psobs, hyam, hybm, qobs, status ) if ( status /= nf90_noerr ) then have_q = .false. if (masterproc) write(iulog,*) sub//':Could not find variable q on IOP file' @@ -710,7 +709,7 @@ subroutine readiopdata(hvcoord) cldobs = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'cld', .false., & - dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldobs, status ) + dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hyam, hybm, cldobs, status ) if ( status /= nf90_noerr ) then have_cld = .false. else @@ -719,7 +718,7 @@ subroutine readiopdata(hvcoord) clwpobs = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'clwp', .false., & - dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, clwpobs, status ) + dummy, fill_ends, scm_crm_mode, dplevs, nlev,psobs, hyam, hybm, clwpobs, status ) if ( status /= nf90_noerr ) then have_clwp = .false. else @@ -742,7 +741,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'divq', have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq(:,1), status ) + dplevs, nlev,psobs, hyam, hybm, divq(:,1), status ) if ( status /= nf90_noerr ) then have_divq = .false. else @@ -765,7 +764,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivq', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivq(:,1), status ) + dplevs, nlev,psobs, hyam, hybm, vertdivq(:,1), status ) if ( status /= nf90_noerr ) then have_vertdivq = .false. else @@ -788,7 +787,7 @@ subroutine readiopdata(hvcoord) do m = 1, pcnst call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dten', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divq3d(:,m), status ) + dplevs, nlev,psobs, hyam, hybm, divq3d(:,m), status ) write(iulog,*)'checking ',trim(cnst_name(m))//'_dten',status if ( status /= nf90_noerr ) then have_cnst(m) = .false. @@ -801,7 +800,7 @@ subroutine readiopdata(hvcoord) coldata = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_dqfx', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, coldata, status ) + dplevs, nlev,psobs, hyam, hybm, coldata, status ) if ( STATUS /= NF90_NOERR ) then dqfxcam(1,:,m)=0._r8 else @@ -811,7 +810,7 @@ subroutine readiopdata(hvcoord) tmpdata = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, trim(cnst_name(m))//'_alph', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, tmpdata, status ) + dplevs, nlev,psobs, hyam, hybm, tmpdata, status ) if ( status /= nf90_noerr ) then alphacam(m)=0._r8 else @@ -827,7 +826,7 @@ subroutine readiopdata(hvcoord) have_srf = .false. call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMLIQ', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numliqobs, status ) + dplevs, nlev,psobs, hyam, hybm, numliqobs, status ) if ( status /= nf90_noerr ) then have_numliq = .false. else @@ -844,7 +843,7 @@ subroutine readiopdata(hvcoord) if ( icldliq > 0 ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDLIQ', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldliqobs, status ) + dplevs, nlev,psobs, hyam, hybm, cldliqobs, status ) if ( status /= nf90_noerr ) then have_cldliq = .false. else @@ -859,7 +858,7 @@ subroutine readiopdata(hvcoord) if ( icldice > 0 ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'CLDICE', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, cldiceobs, status ) + dplevs, nlev,psobs, hyam, hybm, cldiceobs, status ) if ( status /= nf90_noerr ) then have_cldice = .false. else @@ -875,7 +874,7 @@ subroutine readiopdata(hvcoord) have_srf = .false. call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'NUMICE', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, numiceobs, status ) + dplevs, nlev,psobs, hyam, hybm, numiceobs, status ) if ( status /= nf90_noerr ) then have_numice = .false. else @@ -900,7 +899,7 @@ subroutine readiopdata(hvcoord) divu = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divu', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu, status ) + dplevs, nlev,psobs, hyam, hybm, divu, status ) if ( status /= nf90_noerr ) then have_divu = .false. else @@ -921,7 +920,7 @@ subroutine readiopdata(hvcoord) divv = 0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divv', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv, status ) + dplevs, nlev,psobs, hyam, hybm, divv, status ) if ( status /= nf90_noerr ) then have_divv = .false. else @@ -942,7 +941,7 @@ subroutine readiopdata(hvcoord) divt=0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'divT', have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt, status ) + dplevs, nlev,psobs, hyam, hybm, divt, status ) if ( status /= nf90_noerr ) then have_divt = .false. else @@ -964,11 +963,11 @@ subroutine readiopdata(hvcoord) vertdivt=0._r8 call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivTx', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) + dplevs, nlev,psobs, hyam, hybm, vertdivt, status ) if ( status /= nf90_noerr ) then call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'vertdivT', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vertdivt, status ) + dplevs, nlev,psobs, hyam, hybm, vertdivt, status ) if ( status /= nf90_noerr ) then have_vertdivt = .false. else @@ -994,7 +993,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divT3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divt3d, status ) + dplevs, nlev,psobs, hyam, hybm, divt3d, status ) write(iulog,*)'checking divT3d:',status,nf90_noerr if ( status /= nf90_noerr ) then have_divt3d = .false. @@ -1006,7 +1005,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divU3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divu3d, status ) + dplevs, nlev,psobs, hyam, hybm, divu3d, status ) if ( status /= nf90_noerr ) then have_divu3d = .false. else @@ -1017,7 +1016,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'divV3d', & have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, divv3d, status ) + dplevs, nlev,psobs, hyam, hybm, divv3d, status ) if ( status /= nf90_noerr ) then have_divv3d = .false. else @@ -1040,7 +1039,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'omega', .true., ptend, fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, wfld, status ) + dplevs, nlev,psobs, hyam, hybm, wfld, status ) if ( status /= nf90_noerr ) then have_omega = .false. if (masterproc) write(iulog,*) sub//':Could not find variable omega on IOP' @@ -1052,7 +1051,7 @@ subroutine readiopdata(hvcoord) else have_omega = .true. endif - call plevs0(plev ,psobs ,pint,pmid ,pdel, hvcoord) + call plevs0(plev, psobs, ps0, hyam, hybm, hyai, hybi, pint, pmid ,pdel) ! ! Build interface vector for the specified omega profile ! (weighted average in pressure of specified level values) @@ -1077,7 +1076,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'u', have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, uobs, status ) + dplevs, nlev,psobs, hyam, hybm, uobs, status ) if ( status /= nf90_noerr ) then have_u = .false. else @@ -1097,7 +1096,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, & 'v', have_srf, srf(1), fill_ends, scm_crm_mode, & - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, vobs, status ) + dplevs, nlev,psobs, hyam, hybm, vobs, status ) if ( status /= nf90_noerr ) then have_v = .false. else @@ -1117,7 +1116,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q1', & .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q1 at surface - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) + dplevs, nlev,psobs, hyam, hybm, q1obs, status ) if ( status /= nf90_noerr ) then have_q1 = .false. else @@ -1128,7 +1127,7 @@ subroutine readiopdata(hvcoord) call getinterpncdata( ncid, scmlat, scmlon, ioptimeidx, 'Q2', & .false., dummy, fill_ends, scm_crm_mode, & ! datasets don't contain Q2 at surface - dplevs, nlev,psobs, hvcoord%hyam, hvcoord%hybm, q1obs, status ) + dplevs, nlev,psobs, hyam, hybm, q1obs, status ) if ( status /= nf90_noerr ) then have_q2 = .false. else @@ -1306,7 +1305,7 @@ end subroutine setiopupdate !=============================================================================== -subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) +subroutine plevs0 (nver, ps, ps0, hyam, hybm, hyai, hybi, pint ,pmid ,pdel) !----------------------------------------------------------------------- ! @@ -1317,18 +1316,20 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) ! Author: B. Boville ! !----------------------------------------------------------------------- - - use hybvcoord_mod, only : hvcoord_t implicit none !----------------------------------------------------------------------- integer , intent(in) :: nver ! vertical dimension real(r8), intent(in) :: ps ! Surface pressure (pascals) + real(r8), intent(in) :: ps0 ! reference pressure (pascals) + real(r8), intent(in) :: hyam(plev) ! hybrid midpoint coef + real(r8), intent(in) :: hybm(plev) ! hybrid midpoint coef + real(r8), intent(in) :: hyai(plevp) ! hybrid interface coef + real(r8), intent(in) :: hybi(plevp) ! hybrid interface coef real(r8), intent(out) :: pint(nver+1) ! Pressure at model interfaces real(r8), intent(out) :: pmid(nver) ! Pressure at model levels real(r8), intent(out) :: pdel(nver) ! Layer thickness (pint(k+1) - pint(k)) - type (hvcoord_t), intent(in) :: hvcoord !----------------------------------------------------------------------- !---------------------------Local workspace----------------------------- @@ -1339,14 +1340,14 @@ subroutine plevs0 (nver ,ps ,pint ,pmid ,pdel, hvcoord) ! !$OMP PARALLEL DO PRIVATE (K) do k=1,nver+1 - pint(k) = hvcoord%hyai(k)*hvcoord%ps0 + hvcoord%hybi(k)*ps + pint(k) = hyai(k)*ps0 + hybi(k)*ps end do ! ! Set midpoint pressures and layer thicknesses ! !$OMP PARALLEL DO PRIVATE (K) do k=1,nver - pmid(k) = hvcoord%hyam(k)*hvcoord%ps0 + hvcoord%hybm(k)*ps + pmid(k) = hyam(k)*ps0 + hybm(k)*ps pdel(k) = pint(k+1) - pint(k) end do diff --git a/src/dynamics/eul/dyn_comp.F90 b/src/dynamics/eul/dyn_comp.F90 index f9f19f8025..bb753fdd33 100644 --- a/src/dynamics/eul/dyn_comp.F90 +++ b/src/dynamics/eul/dyn_comp.F90 @@ -361,8 +361,8 @@ subroutine read_inidat() use ncdio_atm, only: infld use scamMod, only: setiopupdate,setiopupdate_init,readiopdata - use dyn_grid, only: hvcoord use iop, only: iop_update_prognostics + use hycoef, only: hyam, hybm, hyai, hybi, ps0 ! Local variables integer i,c,m,n,lat ! indices @@ -578,7 +578,7 @@ subroutine read_inidat() loniop(1)=(mod(scmlon-2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8 loniop(2)=(mod(scmlon+2.0_r8+360.0_r8,360.0_r8))*pi/180.0_r8 call setiopupdate() - call readiopdata(hvcoord) + call readiopdata(hyam,hybm,hyai,hybi,ps0) call iop_update_prognostics(1,t3=t3,u3=u3,v3=v3,q3=q3,ps=ps) end if end if diff --git a/src/dynamics/eul/dyn_grid.F90 b/src/dynamics/eul/dyn_grid.F90 index c9036b54ee..62d3d73f0c 100644 --- a/src/dynamics/eul/dyn_grid.F90 +++ b/src/dynamics/eul/dyn_grid.F90 @@ -17,7 +17,6 @@ module dyn_grid use cam_abortutils, only: endrun use cam_logfile, only: iulog -use hybvcoord_mod, only: hvcoord_t use shr_const_mod, only: SHR_CONST_PI, SHR_CONST_REARTH #if (defined SPMD) @@ -49,7 +48,6 @@ module dyn_grid ! from a given global column index get_horiz_grid_d, &! horizontal grid coordinates get_horiz_grid_dim_d, &! horizontal dimensions of dynamics grid - hvcoord, &! vertical coordinate parameters physgrid_copy_attributes_d ! The Eulerian dynamics grids @@ -61,8 +59,6 @@ module dyn_grid integer :: ngcols_d = 0 ! number of dynamics columns -type (hvcoord_t) :: hvcoord - !======================================================================================== contains !======================================================================================== @@ -131,15 +127,6 @@ subroutine dyn_grid_init ! Initialize hybrid coordinate arrays call hycoef_init(fh_ini) - hvcoord%hyam = hyam - hvcoord%hyai = hyai - hvcoord%hybm = hybm - hvcoord%hybi = hybi - hvcoord%ps0 = ps0 - do k = 1, plev - hvcoord%hybd(k) = hvcoord%hybi(k+1) - hvcoord%hybi(k) - end do - ! Initialize reference pressures call ref_pres_init(hypi, hypm, nprlev) diff --git a/src/dynamics/eul/stepon.F90 b/src/dynamics/eul/stepon.F90 index b19caa605c..4c86f1d27e 100644 --- a/src/dynamics/eul/stepon.F90 +++ b/src/dynamics/eul/stepon.F90 @@ -22,7 +22,6 @@ module stepon use aerosol_properties_mod, only: aerosol_properties use aerosol_state_mod, only: aerosol_state use microp_aero, only: aerosol_state_object, aerosol_properties_object - use dyn_grid, only: hvcoord implicit none private @@ -293,6 +292,7 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) use eul_control_mod,only: eul_nsplit use prognostics, only: ps use iop, only: iop_update_prognostics + use hycoef, only: hyam, hybm, hyai, hybi, ps0 real(r8), intent(in) :: ztodt ! twice time step unless nstep=0 type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) @@ -312,7 +312,7 @@ subroutine stepon_run3( ztodt, cam_out, phys_state, dyn_in, dyn_out ) ! Read IOP data and update prognostics if needed if (doiopupdate) then - call readiopdata(hvcoord) + call readiopdata(hyam, hybm, hyai, hybi, ps0) call iop_update_prognostics(n3,ps=ps) end if endif diff --git a/src/dynamics/se/apply_iop_forcing.F90 b/src/dynamics/se/apply_iop_forcing.F90 index dbb52ac1cb..06e2a48472 100644 --- a/src/dynamics/se/apply_iop_forcing.F90 +++ b/src/dynamics/se/apply_iop_forcing.F90 @@ -71,7 +71,7 @@ subroutine advance_iop_forcing(scm_dt, ps_in, & ! In character(len=*), parameter :: subname = 'advance_iop_forcing' ! Get vertical level profiles - call plevs0(plev ,ps_in ,pintm1 ,pmidm1 ,pdelm1, hvcoord) + call plevs0(plev, ps_in, hvcoord%ps0, hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, pintm1 ,pmidm1 ,pdelm1) ! Advance T and Q due to large scale forcing if (use_3dfrc) then @@ -173,7 +173,7 @@ subroutine advance_iop_nudging(ztodt, ps_in, & ! In if ( .not. scm_relaxation) return - call plevs0(plev ,ps_in ,pintm1 ,pmidm1 ,pdelm1, hvcoord) + call plevs0(plev, ps_in, hvcoord%ps0, hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, pintm1 ,pmidm1 ,pdelm1) relax_T(:) = 0._r8 relax_u(:) = 0._r8 diff --git a/src/dynamics/se/dyn_comp.F90 b/src/dynamics/se/dyn_comp.F90 index b4493d7f96..586ee06b1f 100644 --- a/src/dynamics/se/dyn_comp.F90 +++ b/src/dynamics/se/dyn_comp.F90 @@ -11,7 +11,7 @@ module dyn_comp use cam_control_mod, only: initial_run use cam_initfiles, only: initial_file_get_id, topo_file_get_id, pertlim use phys_control, only: use_gw_front, use_gw_front_igw -use dyn_grid, only: ini_grid_name, timelevel, edgebuf, & +use dyn_grid, only: ini_grid_name, timelevel, hvcoord, edgebuf, & ini_grid_hdim_name use cam_grid_support, only: cam_grid_id, cam_grid_get_gcid, & @@ -48,7 +48,7 @@ module dyn_comp use bndry_mod, only: bndry_exchange use se_single_column_mod, only: scm_setinitial use scamMod, only: single_column, readiopdata, use_iop, setiopupdate_init -use hycoef, only: hyai, hybi, ps0, hvcoord +use hycoef, only: hyai, hybi, ps0 implicit none private @@ -753,7 +753,7 @@ subroutine dyn_init(dyn_in, dyn_out) call read_inidat(dyn_in) if (use_iop .and. masterproc) then call setiopupdate_init() - call readiopdata( hvcoord ) + call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) call scm_setinitial(dyn_in%elem) end if call clean_iodesc_list() @@ -1195,6 +1195,7 @@ end subroutine dyn_final subroutine read_inidat(dyn_in) use air_composition, only: thermodynamic_active_species_num, dry_air_species_num use shr_sys_mod, only: shr_sys_flush + use hycoef, only: hyai, hybi, ps0 use const_init, only: cnst_init_default use element_mod, only: timelevels diff --git a/src/dynamics/se/dyn_grid.F90 b/src/dynamics/se/dyn_grid.F90 index 300564ce07..69d9bbc520 100644 --- a/src/dynamics/se/dyn_grid.F90 +++ b/src/dynamics/se/dyn_grid.F90 @@ -44,6 +44,7 @@ module dyn_grid use dimensions_mod, only: ne, np, npsq, fv_nphys, nlev, use_cslam use element_mod, only: element_t use fvm_control_volume_mod, only: fvm_struct +use hybvcoord_mod, only: hvcoord_t use prim_init, only: prim_init1 use edge_mod, only: initEdgeBuffer use edgetype_mod, only: EdgeBuffer_t @@ -67,6 +68,7 @@ module dyn_grid integer, parameter :: ptimelevels = 2 type (TimeLevel_t) :: TimeLevel ! main time level struct (used by tracers) +type (hvcoord_t) :: hvcoord type(element_t), pointer :: elem(:) => null() ! local GLL elements for this task type(fvm_struct), pointer :: fvm(:) => null() ! local FVM elements for this task @@ -75,6 +77,7 @@ module dyn_grid public :: ini_grid_hdim_name public :: ptimelevels public :: TimeLevel +public :: hvcoord public :: elem public :: fvm public :: edgebuf @@ -119,7 +122,8 @@ subroutine dyn_grid_init() ! Initialize SE grid, and decomposition. - use hycoef, only: hycoef_init, hypi, hypm, nprlev + use hycoef, only: hycoef_init, hypi, hypm, nprlev, & + hyam, hybm, hyai, hybi, ps0 use ref_pres, only: ref_pres_init use spmd_utils, only: MPI_MAX, MPI_INTEGER, mpicom use time_manager, only: get_nstep, get_step_size @@ -159,6 +163,15 @@ subroutine dyn_grid_init() ! Initialize hybrid coordinate arrays call hycoef_init(fh_ini, psdry=.true.) + hvcoord%hyam = hyam + hvcoord%hyai = hyai + hvcoord%hybm = hybm + hvcoord%hybi = hybi + hvcoord%ps0 = ps0 + do k = 1, nlev + hvcoord%hybd(k) = hvcoord%hybi(k+1) - hvcoord%hybi(k) + end do + ! Initialize reference pressures call ref_pres_init(hypi, hypm, nprlev) diff --git a/src/dynamics/se/gravity_waves_sources.F90 b/src/dynamics/se/gravity_waves_sources.F90 index 2f8ed10392..a929dfeaf1 100644 --- a/src/dynamics/se/gravity_waves_sources.F90 +++ b/src/dynamics/se/gravity_waves_sources.F90 @@ -115,7 +115,7 @@ subroutine compute_frontogenesis(frontgf,frontga,tl,tlq,elem,ederiv,hybrid,nets, use derivative_mod, only: gradient_sphere, ugradv_sphere use edge_mod, only: edgevpack, edgevunpack use bndry_mod, only: bndry_exchange - use hycoef, only: hvcoord + use dyn_grid, only: hvcoord use dimensions_mod, only: fv_nphys,ntrac use fvm_mapping, only: dyn2phys_vector,dyn2phys diff --git a/src/dynamics/se/se_single_column_mod.F90 b/src/dynamics/se/se_single_column_mod.F90 index f6b19f09b4..1653b2e43e 100644 --- a/src/dynamics/se/se_single_column_mod.F90 +++ b/src/dynamics/se/se_single_column_mod.F90 @@ -324,7 +324,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) ! based on the input scm latitude and longitude !---------------------------------------------------------- - use shr_const_mod, only: pi => SHR_CONST_PI + use shr_const_mod, only: SHR_CONST_PI use cam_abortutils, only: endrun type(element_t), intent(in) :: elem(:) @@ -334,7 +334,7 @@ subroutine scm_dyn_grid_indicies(elem,scmlat,scmlon,ie_scm,i_scm,j_scm,indx_scm) integer :: i, j, indx, ie real(r8) :: scmposlon, minpoint, testlat, testlon, testval integer :: ierr - real(r8), parameter :: rad2deg = 180.0_r8 / pi + real(r8), parameter :: rad2deg = 180.0_r8 / SHR_CONST_PI character(len=*), parameter :: sub = 'scm_dyn_grid_indicies' ie_scm=0 diff --git a/src/dynamics/se/stepon.F90 b/src/dynamics/se/stepon.F90 index 98482ff1c8..2d49a434cc 100644 --- a/src/dynamics/se/stepon.F90 +++ b/src/dynamics/se/stepon.F90 @@ -19,7 +19,7 @@ module stepon use scamMod, only: use_iop, doiopupdate, single_column, & setiopupdate, readiopdata use se_single_column_mod, only: scm_setfield, iop_broadcast -use hycoef, only: hvcoord +use dyn_grid, only: hvcoord use time_manager, only: get_step_size, is_first_restart_step use cam_history, only: outfld, write_camiop, addfld, add_default, horiz_only use cam_history, only: write_inithist, hist_fld_active, fieldname_len @@ -141,13 +141,13 @@ subroutine stepon_run1( dtime_out, phys_state, phys_tend, & ! If first restart step then ensure that IOP data is read if (is_first_restart_step()) then - if (masterproc) call readiopdata( hvcoord ) + if (masterproc) call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) call iop_broadcast() endif iop_update_phase1 = .true. if ((is_first_restart_step() .or. doiopupdate) .and. masterproc) then - call readiopdata(hvcoord) + call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) endif call iop_broadcast() @@ -256,7 +256,7 @@ subroutine stepon_run3(dtime, cam_out, phys_state, dyn_in, dyn_out) ! Update IOP properties e.g. omega, divT, divQ iop_update_phase1 = .false. if (doiopupdate) then - if (masterproc) call readiopdata(hvcoord) + if (masterproc) call readiopdata( hvcoord%hyam, hvcoord%hybm, hvcoord%hyai, hvcoord%hybi, hvcoord%ps0 ) call iop_broadcast() call scm_setfield(dyn_out%elem,iop_update_phase1) endif diff --git a/src/utils/hybvcoord_mod.F90 b/src/utils/hybvcoord_mod.F90 deleted file mode 100644 index 1dbc6a33db..0000000000 --- a/src/utils/hybvcoord_mod.F90 +++ /dev/null @@ -1,28 +0,0 @@ -module hybvcoord_mod - use shr_kind_mod, only: r8=>shr_kind_r8 - use cam_logfile, only: iulog - use pmgrid, only: plev, plevp - use physconst, only: pstd - - implicit none - private - - !----------------------------------------------------------------------- - ! hvcoord_t: Hybrid level definitions: p = a*p0 + b*ps - ! interfaces p(k) = hyai(k)*ps0 + hybi(k)*ps - ! midpoints p(k) = hyam(k)*ps0 + hybm(k)*ps - !----------------------------------------------------------------------- - type, public :: hvcoord_t - real(r8) ps0 ! base state surface-pressure for level definitions - real(r8) hyai(plevp) ! ps0 component of hybrid coordinate - interfaces - real(r8) hyam(plev) ! ps0 component of hybrid coordinate - midpoints - real(r8) hybi(plevp) ! ps component of hybrid coordinate - interfaces - real(r8) hybm(plev) ! ps component of hybrid coordinate - midpoints - real(r8) hybd(plev) ! difference in b (hybi) across layers - real(r8) prsfac ! log pressure extrapolation factor (time, space independent) - real(r8) etam(plev) ! eta-levels at midpoints - real(r8) etai(plevp) ! eta-levels at interfaces - integer nprlev ! number of pure pressure levels at top - integer pad - end type hvcoord_t -end module hybvcoord_mod diff --git a/src/utils/hycoef.F90 b/src/utils/hycoef.F90 index 455875edee..241abf5c7e 100644 --- a/src/utils/hycoef.F90 +++ b/src/utils/hycoef.F90 @@ -10,7 +10,6 @@ module hycoef pio_double, pio_def_dim, pio_def_var, & pio_put_var, pio_get_var, & pio_seterrorhandling, PIO_BCAST_ERROR, PIO_NOERR -use hybvcoord_mod, only: hvcoord_t implicit none private @@ -53,8 +52,6 @@ module hycoef public hycoef_init -type (hvcoord_t),public :: hvcoord - type(var_desc_t) :: hyam_desc, hyai_desc, hybm_desc, hybi_desc, p0_desc public init_restart_hycoef, write_restart_hycoef @@ -248,14 +245,6 @@ subroutine hycoef_init(file, psdry) formula_terms=formula_terms) end if - ! Initialize the hvcoord coordinate - hvcoord%hyam = hyam - hvcoord%hyai = hyai - hvcoord%hybm = hybm - hvcoord%hybi = hybi - hvcoord%hybd = hybd - hvcoord%ps0 = ps0 - if (masterproc) then write(iulog,'(a)')' Layer Locations (*1000) ' do k=1,plev