From db64408fd9f403325aa5a006c75bc99b869261ea Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 1 Apr 2024 14:09:42 -0600 Subject: [PATCH 01/31] Enable relative path specification for IC files These include velocity, thickness, ts, salt, sponge, and ODA inc. files. This change was needed to enable hybrid CESM experiments, allowing the utilization of restart file(s) from different experiment(s). --- .../MOM_state_initialization.F90 | 30 +++++++++++++++---- 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4bddc0965a..a0de043555 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -720,7 +720,10 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "The name of the thickness file.", & fail_if_missing=.not.just_read, do_not_log=just_read) - filename = trim(inputdir)//trim(thickness_file) + filename = trim(thickness_file) + if (scan(thickness_file, "/") == 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(thickness_file) + endif if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/THICKNESS_FILE", filename) if ((.not.just_read) .and. (.not.file_exists(filename, G%Domain))) call MOM_error(FATAL, & @@ -1446,7 +1449,10 @@ subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - filename = trim(inputdir)//trim(velocity_file) + filename = trim(velocity_file) + if (scan(velocity_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(velocity_file) + endif if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) call get_param(param_file, mdl, "U_IC_VAR", u_IC_var, & @@ -1627,7 +1633,10 @@ subroutine initialize_temp_salt_from_file(T, S, G, GV, US, param_file, just_read call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - filename = trim(inputdir)//trim(ts_file) + filename = trim(ts_file) + if (scan(ts_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(ts_file) + endif if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & "The initial condition variable for potential temperature.", & @@ -1647,7 +1656,10 @@ subroutine initialize_temp_salt_from_file(T, S, G, GV, US, param_file, just_read ! Read the temperatures and salinities from netcdf files. call MOM_read_data(filename, temp_var, T(:,:,:), G%Domain, scale=US%degC_to_C) - salt_filename = trim(inputdir)//trim(salt_file) + salt_filename = trim(salt_file) + if (scan(salt_file, '/')== 0) then ! prepend inputdir if only a filename is given + salt_filename = trim(inputdir)//trim(salt_file) + endif if (.not.file_exists(salt_filename, G%Domain)) call MOM_error(FATAL, & " initialize_temp_salt_from_file: Unable to open "//trim(salt_filename)) @@ -1977,7 +1989,10 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t default=.false.) ! Read in sponge damping rate for tracers - filename = trim(inputdir)//trim(damping_file) + filename = trim(damping_file) + if (scan(damping_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(damping_file) + endif call log_param(param_file, mdl, "INPUTDIR/SPONGE_DAMPING_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_sponges: Unable to open "//trim(filename)) @@ -2281,7 +2296,10 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p ! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) ! Read in incremental update for tracers - filename = trim(inputdir)//trim(inc_file) + filename = trim(inc_file) + if (scan(inc_file, '/')== 0) then ! prepend inputdir if only a filename is given + filename = trim(inputdir)//trim(inc_file) + endif call log_param(param_file, mdl, "INPUTDIR/ODA_INCUPD_FILE", filename) if (.not.file_exists(filename, G%Domain)) & call MOM_error(FATAL, " initialize_oda_incupd: Unable to open "//trim(filename)) From f4121ca39829a4edf9b0714a0a74c2385ea53217 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 18 Apr 2024 09:44:40 -0600 Subject: [PATCH 02/31] Write unmasked ocean geometry files When masking is applied, via auto or manual mask_table, create an unmasked MOM6 domain to be used for writing out an unmkased ocean geometry file. --- src/core/MOM.F90 | 26 +++++++++++++++++++++----- src/framework/MOM_domains.F90 | 15 ++++++++++++++- 2 files changed, 35 insertions(+), 6 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b7f8bd3f66..965d7476ab 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -23,7 +23,7 @@ module MOM use MOM_diag_mediator, only : diag_grid_storage, diag_grid_storage_init use MOM_diag_mediator, only : diag_save_grids, diag_restore_grids use MOM_diag_mediator, only : diag_copy_storage_to_diag, diag_copy_diag_to_storage -use MOM_domains, only : MOM_domains_init +use MOM_domains, only : MOM_domains_init, MOM_domain_type use MOM_domains, only : sum_across_PEs, pass_var, pass_vector use MOM_domains, only : clone_MOM_domain, deallocate_MOM_domain use MOM_domains, only : To_North, To_East, To_South, To_West @@ -2011,9 +2011,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents type(hor_index_type), target :: HI_in ! HI on the input grid + type(hor_index_type) :: HI_in_unmasked ! HI on the unmasked input grid type(verticalGrid_type), pointer :: GV => NULL() type(dyn_horgrid_type), pointer :: dG => NULL(), test_dG => NULL() type(dyn_horgrid_type), pointer :: dG_in => NULL() + type(dyn_horgrid_type), pointer :: dG_unmasked_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => NULL() type(MOM_restart_CS), pointer :: restart_CSp => NULL() @@ -2113,6 +2115,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state + type(MOM_domain_type), pointer :: MOM_dom_unmasked => null() ! Unmasked MOM domain instance + ! (To be used for writing out ocean geometry) CS%Time => Time @@ -2541,10 +2545,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & - NJPROC=NJPROC_) + NJPROC=NJPROC_, MOM_dom_unmasked=MOM_dom_unmasked) #else call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & - domain_name="MOM_in") + domain_name="MOM_in", MOM_dom_unmasked=MOM_dom_unmasked) #endif ! Copy input grid (G_in) domain to active grid G @@ -2842,8 +2846,20 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Write out all of the grid data used by this run. new_sim = determine_is_new_run(dirs%input_filename, dirs%restart_input_dir, G_in, restart_CSp) write_geom_files = ((write_geom==2) .or. ((write_geom==1) .and. new_sim)) - if (write_geom_files) call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) - + if (write_geom_files) then + if (associated(MOM_dom_unmasked)) then + call hor_index_init(MOM_dom_unmasked, HI_in_unmasked, param_file, & + local_indexing=.not.global_indexing) + call create_dyn_horgrid(dG_unmasked_in, HI_in_unmasked, bathymetry_at_vel=bathy_at_vel) + call clone_MOM_domain(MOM_dom_unmasked, dG_unmasked_in%Domain) + call MOM_initialize_fixed(dG_unmasked_in, US, OBC_in, param_file, .false., dirs%output_directory) + call write_ocean_geometry_file(dG_unmasked_in, param_file, dirs%output_directory, US=US) + call deallocate_MOM_domain(MOM_dom_unmasked) + call destroy_dyn_horgrid(dG_unmasked_in) + else + call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) + endif + endif call destroy_dyn_horgrid(dG_in) ! Initialize dynamically evolving fields, perhaps from restart files. diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index f2c3225025..22226d3b85 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -65,7 +65,7 @@ module MOM_domains !! properties of the domain type. subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & - min_halo, domain_name, include_name, param_suffix) + min_halo, domain_name, include_name, param_suffix, MOM_dom_unmasked) type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type !! being defined here. type(unit_scale_type), pointer :: US !< A dimensional unit scaling type @@ -99,10 +99,13 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & !! "MOM_memory.h" if missing. character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to !! layout-specific parameters. + type(MOM_domain_type), pointer, optional :: MOM_dom_unmasked !< Unmasked MOM domain instance. + !! Set to null if masking is not enabled. ! Local variables integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions integer, dimension(2) :: auto_layout ! The layout determined by the auto masking routine + integer, dimension(2) :: layout_unmasked ! A temporary layout for unmasked domain integer, dimension(2) :: io_layout ! The layout of logical processors for input and output !$ integer :: ocean_nthreads ! Number of openMP threads !$ logical :: ocean_omp_hyper_thread ! If true use openMP hyper-threads @@ -429,6 +432,16 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & "to be the same as the layout.", default=1, layoutParam=.true.) endif + ! Create an unmasked domain if requested. This is used for writing out unmasked ocean geometry. + if (present(MOM_dom_unmasked) .and. mask_table_exists) then + call MOM_define_layout(n_global, PEs_used, layout_unmasked) + call create_MOM_domain(MOM_dom_unmasked, n_global, n_halo, reentrant, tripolar_N, layout_unmasked, & + domain_name=domain_name, symmetric=symmetric, thin_halos=thin_halos, & + nonblocking=nonblocking) + else + MOM_dom_unmasked => null() + endif + call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, & io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & symmetric=symmetric, thin_halos=thin_halos, nonblocking=nonblocking) From a30e7c8d971bb24d1c41c6d099ad206a1520a39e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 12 Apr 2024 16:19:58 -0400 Subject: [PATCH 03/31] Disable codecov upload requirement This patch removes the code coverage upload requirement. Constraints around codecov.io upload rules have made it impossible to keep this as a requirement. However, we will still attempt an upload, which should be more successful for accounts with a stored URL token, such as NOAA-GFDL. --- .github/workflows/coverage.yml | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 5cd5f91baa..1f5a64ac56 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -31,14 +31,7 @@ jobs: - name: Run (single processor) unit tests run: make run.unit - - name: Report unit test coverage to CI (PR) - if: github.event_name == 'pull_request' - run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - - - name: Report unit test coverage to CI (Push) - if: github.event_name != 'pull_request' + - name: Report unit test coverage to CI run: make report.cov.unit env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} @@ -49,14 +42,7 @@ jobs: - name: Run coverage tests run: make -j -k run.cov - - name: Report coverage to CI (PR) - if: github.event_name == 'pull_request' - run: make report.cov REQUIRE_COVERAGE_UPLOAD=true - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - - - name: Report coverage to CI (Push) - if: github.event_name != 'pull_request' + - name: Report coverage to CI run: make report.cov env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} From d16c330a09de85b4f170f20710ca0ac5f5563821 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 3 May 2024 15:41:18 -0600 Subject: [PATCH 04/31] Introduce GEOM_FILE runtime parameter to set ocean_geometry file name. This is to enable the prefixing of the ocean geometry file with the case (experiment) name, and thus enable adherence to CESM output file naming convention and allow short term archiving of ocean_geometry file. --- src/core/MOM.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 965d7476ab..52941944a9 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2117,6 +2117,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(ocean_internal_state) :: MOM_internal_state type(MOM_domain_type), pointer :: MOM_dom_unmasked => null() ! Unmasked MOM domain instance ! (To be used for writing out ocean geometry) + character(len=240) :: geom_file ! Name of the ocean geometry file CS%Time => Time @@ -2464,6 +2465,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "vertical grid files. Other values are invalid.", default=1) if (write_geom<0 .or. write_geom>2) call MOM_error(FATAL,"MOM: "//& "WRITE_GEOM must be equal to 0, 1 or 2.") + call get_param(param_file, "MOM", "GEOM_FILE", geom_file, & + "The file into which to write the ocean geometry.", & + default="ocean_geometry") call get_param(param_file, "MOM", "USE_DBCLIENT", CS%use_dbclient, & "If true, initialize a client to a remote database that can "//& "be used for online analysis and machine-learning inference.",& @@ -2853,11 +2857,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call create_dyn_horgrid(dG_unmasked_in, HI_in_unmasked, bathymetry_at_vel=bathy_at_vel) call clone_MOM_domain(MOM_dom_unmasked, dG_unmasked_in%Domain) call MOM_initialize_fixed(dG_unmasked_in, US, OBC_in, param_file, .false., dirs%output_directory) - call write_ocean_geometry_file(dG_unmasked_in, param_file, dirs%output_directory, US=US) + call write_ocean_geometry_file(dG_unmasked_in, param_file, dirs%output_directory, US=US, geom_file=geom_file) call deallocate_MOM_domain(MOM_dom_unmasked) call destroy_dyn_horgrid(dG_unmasked_in) else - call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US) + call write_ocean_geometry_file(dG_in, param_file, dirs%output_directory, US=US, geom_file=geom_file) endif endif call destroy_dyn_horgrid(dG_in) From 4584e5ebbdcc850b3e9a3059833d919f987aec95 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 May 2024 15:49:47 -0600 Subject: [PATCH 05/31] Add option to avoid negative MEKE --- src/parameterizations/lateral/MOM_MEKE.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index a44eec7727..4b5e390666 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -82,6 +82,7 @@ module MOM_MEKE !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing length scale. + logical :: MEKE_positive !< If true, it guarantees that MEKE will always be greater than zero. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). @@ -648,6 +649,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call MOM_error(FATAL,"Invalid method specified for calculating EKE") end select + if (CS%MEKE_positive) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + MEKE%MEKE(i,j) = MAX(0., MEKE%MEKE(i,j)) + enddo ; enddo + endif + call cpu_clock_begin(CS%id_clock_pass) call do_group_pass(CS%pass_MEKE, G%Domain) call cpu_clock_end(CS%id_clock_pass) @@ -1228,6 +1236,9 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME call get_param(param_file, mdl, "MEKE_DTSCALE", CS%MEKE_dtScale, & "A scaling factor to accelerate the time evolution of MEKE.", & units="nondim", default=1.0) + call get_param(param_file, mdl, "MEKE_POSITIVE", CS%MEKE_positive, & + "If true, it guarantees that MEKE will always be greater than zero.", & + default=.false.) case("dbclient") CS%eke_src = EKE_DBCLIENT call ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) From a7725dcad75e47352b20d0de703663e497f3b230 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 May 2024 15:57:53 -0600 Subject: [PATCH 06/31] Improve description --- src/parameterizations/lateral/MOM_MEKE.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 4b5e390666..298ae76c05 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -81,8 +81,7 @@ module MOM_MEKE logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. - logical :: use_min_lscale !< Use simple minimum for mixing length scale. - logical :: MEKE_positive !< If true, it guarantees that MEKE will always be greater than zero. + logical :: use_min_lscale !< Use simple minimum for mixing l >= 0. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). @@ -1237,7 +1236,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "A scaling factor to accelerate the time evolution of MEKE.", & units="nondim", default=1.0) call get_param(param_file, mdl, "MEKE_POSITIVE", CS%MEKE_positive, & - "If true, it guarantees that MEKE will always be greater than zero.", & + "If true, it guarantees that MEKE will always be >= 0.", & default=.false.) case("dbclient") CS%eke_src = EKE_DBCLIENT From 0d5584158811de86e29e4037757908d64b42ca40 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 May 2024 16:04:12 -0600 Subject: [PATCH 07/31] Add MEKE_positive to the control structure --- src/parameterizations/lateral/MOM_MEKE.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 298ae76c05..96edd94b76 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -82,6 +82,7 @@ module MOM_MEKE !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing l >= 0. + logical :: MEKE_positive !< If true, it guarantees that MEKE will always be >= 0. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). From 95259e42f0c7faf259ecac26917e231b985417af Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 May 2024 16:56:06 -0600 Subject: [PATCH 08/31] Revert a comment that was changed unintentionally. --- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 96edd94b76..d269171da9 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -81,7 +81,7 @@ module MOM_MEKE logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. - logical :: use_min_lscale !< Use simple minimum for mixing l >= 0. + logical :: use_min_lscale !< Use simple minimum for mixing length scale. logical :: MEKE_positive !< If true, it guarantees that MEKE will always be >= 0. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] From 2b1201a87259c912c93e4c11039b8e59971e3c26 Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Fri, 24 May 2024 13:11:43 -0600 Subject: [PATCH 09/31] KE-conserving correction to velocity remap (#277) * KE-conserving Remap Correction This commit introduces a method that corrects the remapped velocity so that it conserves KE. The correction is activated by setting `REMAP_VEL_CONSERVE_KE = True` The commit also introduces two new diagnostics: `ale_u2` and `ale_v2` These track the change in depth-integrated KE of the u and v components of velocity before the correction is applied. They can be used even if the remapping correction is not turned on. * Limit KE-conserving correction This commit does two main things. - Limit the magnitude of the multiplicative correction applied to the baroclinic velocity to +25%. This prevents rare occasions where the correction creates very large baroclinic velocities. - Move the diagnostic of KE loss/gain from before the correction to after the correction. Without the limit (above) the correction is exact to machine precision, so there was no point in computing it after the correction. With the new limit it makes sense to compute the diagnostic after the correction. * Fix dimensional scaling error * Correct Units This commit addresses @Hallberg-NOAA's comments on [the PR](https://github.com/NCAR/MOM6/pull/277). Computations of `ale_u2` and `ale_v2` are updated to work correctly in both Boussinesq and non-Boussinesq modes. --- src/ALE/MOM_ALE.F90 | 139 ++++++++++++++++++++++++++++++++++++++++++-- src/core/MOM.F90 | 3 +- 2 files changed, 136 insertions(+), 6 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 77ee1192a2..600439d5b2 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -97,6 +97,9 @@ module MOM_ALE !! values result in the use of more robust and accurate forms of !! mathematically equivalent expressions. + logical :: conserve_ke !< Apply a correction to the baroclinic velocity after remapping to + !! conserve KE. + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: show_call_tree !< For debugging @@ -117,6 +120,8 @@ module MOM_ALE integer :: id_e_preale = -1 !< diagnostic id for interface heights before ALE. integer :: id_vert_remap_h = -1 !< diagnostic id for layer thicknesses used for remapping integer :: id_vert_remap_h_tendency = -1 !< diagnostic id for layer thickness tendency due to ALE + integer :: id_remap_delta_integ_u2 = -1 !< Change in depth-integrated rho0*u**2/2 + integer :: id_remap_delta_integ_v2 = -1 !< Change in depth-integrated rho0*v**2/2 end type @@ -298,6 +303,11 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) if (CS%use_hybgen_unmix) & call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + call get_param(param_file, mdl, "REMAP_VEL_CONSERVE_KE", CS%conserve_ke, & + "If true, a correction is applied to the baroclinic component of velocity "//& + "after remapping so that total KE is conserved. KE may not be conserved "//& + "when (CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)", & + default=.false.) call get_param(param_file, "MOM", "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) @@ -341,13 +351,23 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) CS%id_dzRegrid = register_diag_field('ocean_model', 'dzRegrid', diag%axesTi, Time, & 'Change in interface height due to ALE regridding', 'm', conversion=GV%H_to_m) - cs%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', diag%axestl, Time, & + CS%id_vert_remap_h = register_diag_field('ocean_model', 'vert_remap_h', diag%axestl, Time, & 'layer thicknesses after ALE regridding and remapping', & thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) - cs%id_vert_remap_h_tendency = register_diag_field('ocean_model', & + CS%id_vert_remap_h_tendency = register_diag_field('ocean_model', & 'vert_remap_h_tendency', diag%axestl, Time, & 'Layer thicknesses tendency due to ALE regridding and remapping', & trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) + CS%id_remap_delta_integ_u2 = register_diag_field('ocean_model', 'ale_u2', diag%axesCu1, Time, & + 'Rate of change in half rho0 times depth integral of squared zonal'//& + ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& + ' this measures the change before the KE-conserving correction is applied.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2 * US%L_to_Z**2) + CS%id_remap_delta_integ_v2 = register_diag_field('ocean_model', 'ale_v2', diag%axesCv1, Time, & + 'Rate of change in half rho0 times depth integral of squared meridional'//& + ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& + ' this measures the change before the KE-conserving correction is applied.', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2 * US%L_to_Z**2) end subroutine ALE_register_diags @@ -1020,7 +1040,8 @@ end subroutine ALE_remap_set_h_vel_OBC !! This routine may be called during initialization of the model at time=0, to !! remap initial conditions to the model grid. It is also called during a !! time step to update the state. -subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug) +subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug, & + dt, allow_preserve_variance) type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -1041,6 +1062,9 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree + real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, optional, intent(in) :: allow_preserve_variance !< If true, enables ke-conserving + !! correction ! Local variables real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] @@ -1051,6 +1075,16 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + real :: rescale_coef ! Factor that scales the baroclinic velocity to conserve ke [nondim] + real :: u_bt, v_bt ! Depth-averaged velocity components [L T-1 ~> m s-1] + real :: ke_c_src, ke_c_tgt ! \int [u_c or v_c]^2 dz on src and tgt grids [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G)) :: du2h_tot ! The rate of change of vertically integrated + ! 0.5 * rho0 * u**2 [R Z L2 T-3 ~> W m-2] + real, dimension(SZI_(G),SZJB_(G)) :: dv2h_tot ! The rate of change of vertically integrated + ! 0.5 * rho0 * v**2 [R Z L2 T-3 ~> W m-2] + real :: u2h_tot, v2h_tot ! The vertically integrated u**2 and v**2 [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: I_dt ! 1 / dt [T-1 ~> s-1] + logical :: variance_option ! Contains the value of allow_preserve_variance when present, else false logical :: show_call_tree integer :: i, j, k, nz @@ -1058,6 +1092,17 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_remap_velocities()") + ! Setup related to KE conservation + variance_option = .false. + if (present(allow_preserve_variance)) variance_option=allow_preserve_variance + if (present(dt)) I_dt = 1.0 / dt + + if (CS%id_remap_delta_integ_u2>0) du2h_tot(:,:) = 0. + if (CS%id_remap_delta_integ_v2>0) dv2h_tot(:,:) = 0. + + if (((CS%id_remap_delta_integ_u2>0) .or. (CS%id_remap_delta_integ_v2>0)) .and. .not.present(dt))& + call MOM_error(FATAL, "ALE KE diagnostics requires passing dt into ALE_remap_velocities") + if (CS%answer_date >= 20190101) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then @@ -1070,7 +1115,9 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u ! --- Remap u profiles from the source vertical grid onto the new target grid. - !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt) + !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt, & + !$OMP u_bt,ke_c_src,ke_c_tgt,rescale_coef, & + !$OMP u2h_tot,v2h_tot) do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then ! Make a 1-d copy of the start and final grids and the source velocity do k=1,nz @@ -1079,9 +1126,47 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u u_src(k) = u(I,j,k) enddo + if (CS%id_remap_delta_integ_u2>0) then + u2h_tot = 0. + do k=1,nz + u2h_tot = u2h_tot - h1(k) * (u_src(k)**2) + enddo + endif + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & h_neglect, h_neglect_edge) + if (variance_option .and. CS%conserve_ke) then + ! Conserve ke_u by correcting baroclinic component. + ! Assumes total depth doesn't change during remap, and + ! that \int u(z) dz doesn't change during remap. + ! First get barotropic component + u_bt = 0.0 + do k=1,nz + u_bt = u_bt + h2(k) * u_tgt(k) ! Dimensions [H L T-1] + enddo + u_bt = u_bt / (sum(h2(1:nz)) + h_neglect) ! Dimensions return to [L T-1] + ! Next get baroclinic ke = \int (u-u_bt)^2 from source and target + ke_c_src = 0.0 + ke_c_tgt = 0.0 + do k=1,nz + ke_c_src = ke_c_src + h1(k) * (u_src(k) - u_bt)**2 + ke_c_tgt = ke_c_tgt + h2(k) * (u_tgt(k) - u_bt)**2 + enddo + ! Next rescale baroclinic component on target grid to conserve ke + rescale_coef = min(1.25, sqrt(ke_c_src / (ke_c_tgt + 1.E-19))) + do k=1,nz + u_tgt(k) = u_bt + rescale_coef * (u_tgt(k) - u_bt) + enddo + endif + + if (CS%id_remap_delta_integ_u2>0) then + do k=1,nz + u2h_tot = u2h_tot + h2(k) * (u_tgt(k)**2) + enddo + du2h_tot(I,j) = GV%H_to_RZ * u2h_tot * I_dt + endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) @@ -1091,12 +1176,16 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u enddo !k endif ; enddo ; enddo + if (CS%id_remap_delta_integ_u2>0) call post_data(CS%id_remap_delta_integ_u2, du2h_tot, CS%diag) + if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") ! --- Remap v profiles from the source vertical grid onto the new target grid. - !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt) + !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt, & + !$OMP v_bt,ke_c_src,ke_c_tgt,rescale_coef, & + !$OMP u2h_tot,v2h_tot) do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then do k=1,nz @@ -1105,9 +1194,47 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u v_src(k) = v(i,J,k) enddo + if (CS%id_remap_delta_integ_v2>0) then + v2h_tot = 0. + do k=1,nz + v2h_tot = v2h_tot - h1(k) * (v_src(k)**2) + enddo + endif + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & h_neglect, h_neglect_edge) + if (variance_option .and. CS%conserve_ke) then + ! Conserve ke_v by correcting baroclinic component. + ! Assumes total depth doesn't change during remap, and + ! that \int v(z) dz doesn't change during remap. + ! First get barotropic component + v_bt = 0.0 + do k=1,nz + v_bt = v_bt + h2(k) * v_tgt(k) ! Dimensions [H L T-1] + enddo + v_bt = v_bt / (sum(h2(1:nz)) + h_neglect) ! Dimensions return to [L T-1] + ! Next get baroclinic ke = \int (u-u_bt)^2 from source and target + ke_c_src = 0.0 + ke_c_tgt = 0.0 + do k=1,nz + ke_c_src = ke_c_src + h1(k) * (v_src(k) - v_bt)**2 + ke_c_tgt = ke_c_tgt + h2(k) * (v_tgt(k) - v_bt)**2 + enddo + ! Next rescale baroclinic component on target grid to conserve ke + rescale_coef = min(1.25, sqrt(ke_c_src / (ke_c_tgt + 1.E-19))) + do k=1,nz + v_tgt(k) = v_bt + rescale_coef * (v_tgt(k) - v_bt) + enddo + endif + + if (CS%id_remap_delta_integ_v2>0) then + do k=1,nz + v2h_tot = v2h_tot + h2(k) * (v_tgt(k)**2) + enddo + dv2h_tot(I,j) = GV%H_to_RZ * v2h_tot * I_dt + endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) endif @@ -1118,6 +1245,8 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u enddo !k endif ; enddo ; enddo + if (CS%id_remap_delta_integ_v2>0) call post_data(CS%id_remap_delta_integ_v2, dv2h_tot, CS%diag) + if (show_call_tree) call callTree_waypoint("v remapped (ALE_remap_velocities)") if (show_call_tree) call callTree_leave("ALE_remap_velocities()") diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 52941944a9..9098b245dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1641,7 +1641,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & endif ! Remap the velocity components. - call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree) + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree, & + dtdia, allow_preserve_variance=.true.) if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. From 6ad1530c3770fb400e980aff6b724e1c5639a1cf Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Tue, 2 Jul 2024 14:00:14 -0600 Subject: [PATCH 10/31] Stochastic GM+E (#280) * SKEB+GM This commit adds a Stochastic Kinetic Energy Backscatter Scheme (SKEBS) where the amplitude of the backscatter is based on either the GM work rate and/or the viscous work rate (FrictWork). Each of these can be multiplied by a coefficient so that, e.g. the backscatter rate could be 50% of the GM work rate plus 20% of the viscous work rate. The vertical structure of the backscatter rate associated with GM has vertical structure given by the EBT profile. This code was developed starting from Phil Pegion's branch, and it builds on the stochastic physics package (external) developed by Phil Pegion, Niraj Agarwal, and collaborators. This package allows the length and time scales of the backscatter to be set via namelist parameters. This commit may break the stochastic EPBL and SPPT schemes developed by P. Pegion. * Fix merge * Whitespace --- .../stochastic_physics/stochastic_physics.F90 | 11 +- src/core/MOM.F90 | 22 +- src/core/MOM_dynamics_split_RK2.F90 | 6 +- src/core/MOM_dynamics_unsplit.F90 | 8 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 6 +- .../lateral/MOM_hor_visc.F90 | 18 +- .../lateral/MOM_thickness_diffuse.F90 | 59 ++- .../stochastic/MOM_stochastics.F90 | 390 ++++++++++++++++-- 8 files changed, 453 insertions(+), 67 deletions(-) diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 index 14fa1bf289..fdfd701892 100644 --- a/config_src/external/stochastic_physics/stochastic_physics.F90 +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -16,7 +16,7 @@ module stochastic_physics !> Initializes the stochastic physics perturbations. subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_epbl_in, do_sppt_in, & - mpiroot, mpicomm, iret) + do_skeb_in,mpiroot, mpicomm, iret) real, intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn [s] integer, intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid integer, intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid @@ -25,6 +25,7 @@ subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_ real, intent(in) :: geoLatT(nx,ny) !< Latitude in degrees logical, intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations logical, intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations + logical, intent(in) :: do_skeb_in !< logical flag, if true generate random pattern for SKEB perturbations integer, intent(in) :: mpiroot !< root processor integer, intent(in) :: mpicomm !< mpi communicator integer, intent(out) :: iret !< return code @@ -38,14 +39,20 @@ subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_ call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_sppt needs to be false if using the stub') iret=-1 endif + if (do_skeb_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_skeb needs to be false if using the stub') + iret=-1 + endif ! This stub function does not actually do anything. return end subroutine init_stochastic_physics_ocn + !> Determines the stochastic physics perturbations. -subroutine run_stochastic_physics_ocn(sppt_wts, t_rp1, t_rp2) +subroutine run_stochastic_physics_ocn(sppt_wts, skeb_wts, t_rp1, t_rp2) real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] + real, intent(inout) :: skeb_wts(:,:) !< array containing random weights for SKEB real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL !! perturbations (KE generation) range [0,2] real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9098b245dd..7b080a5537 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -64,7 +64,7 @@ module MOM use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_diabatic_driver, only : register_diabatic_restarts -use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS +use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS, apply_skeb use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics use MOM_diagnostics, only : register_surface_diags, write_static_fields @@ -741,7 +741,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif endif ! advance the random pattern if stochastic physics is active - if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) + if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl .OR. CS%stoch_CS%do_skeb) & + call update_stochastics(CS%stoch_CS) if (do_dyn) then if (nonblocking_p_surf_update) & @@ -1151,7 +1152,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%VarMix%use_variable_mixing) & call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & - CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, & + CS%stoch_CS) call cpu_clock_end(id_clock_thick_diff) call pass_var(h, G%Domain, clock=id_clock_pass, halo=max(2,CS%cont_stencil)) if (showCallTree) call callTree_waypoint("finished thickness_diffuse_first (step_MOM)") @@ -1223,7 +1225,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & - CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, CS%stoch_CS, waves=waves) if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT @@ -1237,11 +1239,13 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%use_RK2) then call step_MOM_dyn_unsplit_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_RK2_CSp, CS%VarMix, CS%MEKE, CS%pbv, & + CS%stoch_CS) else call step_MOM_dyn_unsplit(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, Waves=Waves) + CS%eta_av_bc, G, GV, US, CS%dyn_unsplit_CSp, CS%VarMix, CS%MEKE, CS%pbv, & + CS%stoch_CS, Waves=Waves) endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_unsplit (step_MOM)") @@ -1282,7 +1286,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (CS%VarMix%use_variable_mixing) & call calc_slope_functions(h, CS%tv, dt, G, GV, US, CS%VarMix, OBC=CS%OBC) call thickness_diffuse(h, CS%uhtr, CS%vhtr, CS%tv, dt, G, GV, US, & - CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp) + CS%MEKE, CS%VarMix, CS%CDp, CS%thickness_diffuse_CSp, CS%stoch_CS) if (CS%debug) call hchksum(h,"Post-thickness_diffuse h", G%HI, haloshift=1, scale=GV%H_to_MKS) call cpu_clock_end(id_clock_thick_diff) @@ -1584,6 +1588,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & Time_end_thermo, G, GV, US, CS%diabatic_CSp, CS%stoch_CS, CS%OBC, Waves) fluxes%fluxes_used = .true. + if (CS%stoch_CS%do_skeb) then + call apply_skeb(CS%G,CS%GV,CS%stoch_CS,CS%u,CS%v,CS%h,CS%tv,dtdia,Time_end_thermo) + endif + if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") ! Regridding/remapping is done here, at end of thermodynamics time step diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index debc63cb46..4bbd03a46a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -59,6 +59,7 @@ module MOM_dynamics_split_RK2 use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_stochastics, only : stochastic_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS use MOM_self_attr_load, only : SAL_CS use MOM_self_attr_load, only : SAL_init, SAL_end @@ -286,7 +287,7 @@ module MOM_dynamics_split_RK2 !> RK2 splitting for time stepping MOM adiabatic dynamics subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_surf_begin, p_surf_end, & uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, calc_dtbt, VarMix, & - MEKE, thickness_diffuse_CSp, pbv, Waves) + MEKE, thickness_diffuse_CSp, pbv, STOCH, Waves) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -326,6 +327,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing !! interface height diffusivities type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing !! fields related to the surface wave conditions @@ -851,7 +853,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & - ADp=CS%ADp) + ADp=CS%ADp, STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index c87e6e9958..f1d3311a89 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -87,8 +87,9 @@ module MOM_dynamics_unsplit use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_stochastics, only : stochastic_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -189,7 +190,7 @@ module MOM_dynamics_unsplit !! 3rd order (for the inviscid momentum equations) order scheme subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & - VarMix, MEKE, pbv, Waves) + VarMix, MEKE, pbv, STOCH, Waves) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -223,6 +224,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing !! fields related to the surface wave conditions @@ -263,7 +265,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index b515229566..3c71fac0e4 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -87,6 +87,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_stochastics, only : stochastic_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS @@ -192,7 +193,7 @@ module MOM_dynamics_unsplit_RK2 !> Step the MOM6 dynamics using an unsplit quasi-2nd order Runge-Kutta scheme subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & - VarMix, MEKE, pbv) + VarMix, MEKE, pbv, STOCH) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -237,6 +238,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, !! fields related to the Mesoscale !! Eddy Kinetic Energy. type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! Averaged layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted layer thicknesses [H ~> m or kg m-2] @@ -276,7 +278,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc) + G, GV, US, CS%hor_visc, STOCH=STOCH) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) call pass_vector(CS%diffu, CS%diffv, G%Domain, clock=id_clock_pass) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 9b1d81348e..d59e6b3871 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -20,6 +20,7 @@ module MOM_hor_visc use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE +use MOM_stochastics, only : stochastic_CS use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : accel_diag_ptrs @@ -241,7 +242,7 @@ module MOM_hor_visc !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD, ADp) + CS, OBC, BT, TD, ADp, STOCH) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -265,6 +266,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + type(stochastic_CS), intent(inout), optional :: STOCH !< Stochastic control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -395,6 +397,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: apply_OBC = .false. logical :: use_MEKE_Ku logical :: use_MEKE_Au + logical :: skeb_use_frict integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -426,6 +429,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + skeb_use_frict = .false. + if (present(STOCH)) skeb_use_frict = STOCH%skeb_use_frict + m_leithy(:,:) = 0.0 ! Initialize if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then @@ -588,12 +594,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, & + !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, skeb_use_frict, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, STOCH & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -1786,6 +1792,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo ; endif + if (skeb_use_frict) then ; do j=js,je ; do i=is,ie + ! Note that the sign convention is FrictWork < 0 means energy dissipation. + STOCH%skeb_diss(i,j,k) = STOCH%skeb_diss(i,j,k) - STOCH%skeb_frict_coef * & + FrictWork(i,j,k) / (GV%H_to_RZ * (h(i,j,k) + h_neglect)) + enddo ; enddo ; endif + ! Make a similar calculation as for FrictWork above but accumulating into ! the vertically integrated MEKE source term, and adjusting for any ! energy loss seen as a reduction in the (biharmonic) frictional source term. diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 2638ca71e1..52b55ad252 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -18,6 +18,7 @@ module MOM_thickness_diffuse use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type +use MOM_stochastics, only : stochastic_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, cont_diag_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -119,7 +120,7 @@ module MOM_thickness_diffuse !> Calculates isopycnal height diffusion coefficients and applies isopycnal height diffusion !! by modifying to the layer thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. -subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) +subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS, STOCH) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -134,6 +135,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(VarMix_CS), target, intent(in) :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse + type(stochastic_CS), intent(inout) :: STOCH !< Stochastic control structure ! Local variables real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. @@ -477,12 +479,23 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif ! Calculate uhD, vhD from h, e, KH_u, KH_v, tv%T/S - if (use_stored_slopes) then - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + if (STOCH%skeb_use_gm) then + if (use_stored_slopes) then + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y, & + STOCH=STOCH, VarMix=VarMix) + else + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, STOCH=STOCH, VarMix=VarMix) + endif else - call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & - int_slope_u, int_slope_v) + if (use_stored_slopes) then + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v, VarMix%slope_x, VarMix%slope_y) + else + call thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, CS, & + int_slope_u, int_slope_v) + endif endif if (VarMix%use_variable_mixing) then @@ -593,7 +606,7 @@ end subroutine thickness_diffuse !! Fluxes are limited to give positive definite thicknesses. !! Called by thickness_diffuse(). subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV, US, MEKE, & - CS, int_slope_u, int_slope_v, slope_x, slope_y) + CS, int_slope_u, int_slope_v, slope_x, slope_y, STOCH, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -622,6 +635,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + type(stochastic_CS), optional, intent(inout) :: STOCH !< Stochastic control structure + type(VarMix_CS), target, optional, intent(in) :: VarMix !< Variable mixing coefficents ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & @@ -759,6 +774,11 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! [H L2 T-1 ~> m3 s-1 or kg s-1] real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before ! applying limiters [Z L2 T-1 ~> m3 s-1] + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + real, allocatable :: skeb_gm_work(:,:) ! Temp array to hold GM work for SKEB + real, allocatable :: skeb_ebt_norm2(:,:) ! Used to normalize EBT for SKEB + real :: h_tot ! total depth [H ~> m] + logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. @@ -766,7 +786,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! state calculations at v-points. integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of ! state calculations at h points with 1 extra halo point - logical :: use_stanley + logical :: use_stanley, skeb_use_gm integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; IsdB = G%IsdB @@ -786,6 +806,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV use_stanley = CS%use_stanley_gm + skeb_use_gm = .false. + if (present(STOCH)) skeb_use_gm = STOCH%skeb_use_gm + if (skeb_use_gm) then + allocate(skeb_gm_work(is:ie,js:je), source=0.) + allocate(skeb_ebt_norm2(is:ie,js:je), source=0.) + endif + nk_linear = max(GV%nkml, 1) Slope_x_PE(:,:,:) = 0.0 @@ -795,6 +822,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV find_work = allocated(MEKE%GM_src) find_work = (allocated(CS%GMwork) .or. find_work) + find_work = (skeb_use_gm .or. find_work) if (use_EOS) then halo = 1 ! Default halo to fill is 1 @@ -1548,8 +1576,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (.not. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + Work_h endif ; endif + if (skeb_use_gm) then + h_tot = sum(h(i,j,1:nz)) + skeb_gm_work(i,j) = STOCH%skeb_gm_coef * Work_h + skeb_ebt_norm2(i,j) = GV%H_to_RZ * & + (sum(h(i,j,1:nz) * VarMix%ebt_struct(i,j,1:nz)**2) + h_neglect) + endif enddo ; enddo ; endif + if (skeb_use_gm) then + ! This block spreads the GM work down through the column using the ebt vertical structure, squared. + ! Note the sign convention. + do k=1,nz ; do j=js,je ; do i=is,ie + STOCH%skeb_diss(i,j,k) = STOCH%skeb_diss(i,j,k) - skeb_gm_work(i,j) * & + VarMix%ebt_struct(i,j,k)**2 / skeb_ebt_norm2(i,j) + enddo ; enddo ; enddo + endif + if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then do j=js,je ; do i=is,ie ; do k=nz,1,-1 PE_release_h = -0.25 * (GV%H_to_RZ*US%L_to_Z**2) * & diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 04a29019fa..1bc42660d3 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -8,8 +8,12 @@ module MOM_stochastics ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! -use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type +use MOM_debugging, only : hchksum, uvchksum, qchksum +use MOM_diag_mediator, only : register_diag_field, diag_ctrl, time_type, post_data +use MOM_diag_mediator, only : register_static_field, enable_averages, disable_averaging use MOM_grid, only : ocean_grid_type +use MOM_variables, only : thermo_var_ptrs +use MOM_domains, only : pass_var, pass_vector, CORNER, SCALAR_PAIR use MOM_verticalGrid, only : verticalGrid_type use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave @@ -18,28 +22,56 @@ module MOM_stochastics use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain use MOM_domains, only : root_PE, num_PEs use MOM_coms, only : Get_PElist +use MOM_EOS, only : calculate_density, EOS_domain use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn #include implicit none ; private -public stochastics_init, update_stochastics +public stochastics_init, update_stochastics, apply_skeb !> This control structure holds parameters for the MOM_stochastics module type, public:: stochastic_CS logical :: do_sppt !< If true, stochastically perturb the diabatic + logical :: do_skeb !< If true, stochastically perturb the diabatic + logical :: skeb_use_gm !< If true, adds GM work to the amplitude of SKEBS + logical :: skeb_use_frict !< If true, adds viscous dissipation rate to the amplitude of SKEBS logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and genration terms - integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT - integer :: id_epbl1_wts = -1 !< Diagnostic id for epbl generation perturbation - integer :: id_epbl2_wts = -1 !< Diagnostic id for epbl dissipation perturbation + integer :: id_sppt_wts = -1 !< Diagnostic id for SPPT + integer :: id_skeb_wts = -1 !< Diagnostic id for SKEB + integer :: id_skebu = -1 !< Diagnostic id for SKEB + integer :: id_skebv = -1 !< Diagnostic id for SKEB + integer :: id_diss = -1 !< Diagnostic id for SKEB + integer :: skeb_npass = -1 !< number of passes of the 9-point smoother for the dissipation estimate + integer :: id_psi = -1 !< Diagnostic id for SPPT + integer :: id_epbl1_wts = -1 !< Diagnostic id for epbl generation perturbation + integer :: id_epbl2_wts = -1 !< Diagnostic id for epbl dissipation perturbation + integer :: id_skeb_taperu = -1 !< Diagnostic id for u taper of SKEB velocity increment + integer :: id_skeb_taperv = -1 !< Diagnostic id for v taper of SKEB velocity increment + real :: skeb_gm_coef !< If skeb_use_gm is true, then skeb_gm_coef * GM_work is added to the + !! dissipation rate used to set the amplitude of SKEBS [nondim] + real :: skeb_frict_coef !< If skeb_use_frict is true, then skeb_gm_coef * GM_work is added to the + !! dissipation rate used to set the amplitude of SKEBS [nondim] + real, allocatable :: skeb_diss(:,:,:) !< Dissipation rate used to set amplitude of SKEBS [L2 T-3 ~> m2 s-2] + !! Index into this at h points. ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT !! tendencies with a number between 0 and 2 + real, allocatable :: skeb_wts(:,:) !< Random pattern for ocean SKEB real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation - type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) + type(diag_ctrl), pointer :: diag=>NULL() !< A structure that is used to regulate the + + ! Taper array to smoothly zero out the SKEBS velocity increment near land + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: taperCu !< Taper applied to u component of + !! stochastic velocity increment + !! range [0,1], [nondim] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: taperCv !< Taper applied to v component of + !! stochastic velocity increment + !! range [0,1], [nondim] + end type stochastic_CS contains @@ -62,20 +94,24 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: pe_zero ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo + integer :: i, j, k ! loop indices + real :: tmp(grid%isdB:grid%iedB,grid%jsdB:grid%jedB) ! Used to construct tapers + integer :: taper_width ! Width (in cells) of the taper that brings the stochastic velocity + ! increments to 0 at the boundary. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "ocean_stochastics_init" ! This module's name. - call callTree_enter("ocean_model_stochastic_init(), MOM_stochastics.F90") + call callTree_enter("stochastic_init(), MOM_stochastics.F90") if (associated(CS)) then call MOM_error(WARNING, "MOM_stochastics_init called with an "// & "associated control structure.") return else ; allocate(CS) ; endif - CS%diag => diag CS%Time => Time + CS%diag => diag ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -83,48 +119,130 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) ! get number of processors and PE list for stochastic physics initialization call get_param(param_file, mdl, "DO_SPPT", CS%do_sppt, & "If true, then stochastically perturb the thermodynamic "//& - "tendemcies of T,S, amd h. Amplitude and correlations are "//& + "tendencies of T,S, amd h. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) + call get_param(param_file, mdl, "DO_SKEB", CS%do_skeb, & + "If true, then stochastically perturb the currents "//& + "using the stochastic kinetic energy backscatter scheme.",& + default=.false.) + call get_param(param_file, mdl, "SKEB_NPASS", CS%skeb_npass, & + "number of passes of a 9-point smoother of the "//& + "dissipation estimate.", default=3, do_not_log=.not.CS%do_skeb) + call get_param(param_file, mdl, "SKEB_TAPER_WIDTH", taper_width, & + "number of cells over which the stochastic velocity increment "//& + "is tapered to zero.", default=4, do_not_log=.not.CS%do_skeb) + call get_param(param_file, mdl, "SKEB_USE_GM", CS%skeb_use_gm, & + "If true, adds GM work rate to the SKEBS amplitude.", & + default=.false., do_not_log=.not.CS%do_skeb) + if ((.not. CS%do_skeb) .and. (CS%skeb_use_gm)) call MOM_error(FATAL, "If SKEB_USE_GM is True "//& + "then DO_SKEB must also be True.") + call get_param(param_file, mdl, "SKEB_GM_COEF", CS%skeb_gm_coef, & + "Fraction of GM work that is added to backscatter rate.", & + units="nondim", default=0.0, do_not_log=.not.CS%skeb_use_gm) + call get_param(param_file, mdl, "SKEB_USE_FRICT", CS%skeb_use_frict, & + "If true, adds horizontal friction dissipation rate "//& + "to the SKEBS amplitude.", default=.false., do_not_log=.not.CS%do_skeb) + if ((.not. CS%do_skeb) .and. (CS%skeb_use_frict)) call MOM_error(FATAL, "If SKEB_USE_FRICT is "//& + "True then DO_SKEB must also be True.") + call get_param(param_file, mdl, "SKEB_FRICT_COEF", CS%skeb_frict_coef, & + "Fraction of horizontal friction work that is added to backscatter rate.", & + units="nondim", default=0.0, do_not_log=.not.CS%skeb_use_frict) call get_param(param_file, mdl, "PERT_EPBL", CS%pert_epbl, & "If true, then stochastically perturb the kinetic energy "//& "production and dissipation terms. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) - if (CS%do_sppt .OR. CS%pert_epbl) then - num_procs = num_PEs() - allocate(pelist(num_procs)) - call Get_PElist(pelist,commID = mom_comm) - pe_zero = root_PE() - nx = grid%ied - grid%isd + 1 - ny = grid%jed - grid%jsd + 1 - call init_stochastic_physics_ocn(dt,grid%geoLonT,grid%geoLatT,nx,ny,GV%ke, & - CS%pert_epbl,CS%do_sppt,pe_zero,mom_comm,iret) - if (iret/=0) then - call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") - endif - - if (CS%do_sppt) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) - if (CS%pert_epbl) then - allocate(CS%epbl1_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) - allocate(CS%epbl2_wts(grid%isd:grid%ied,grid%jsd:grid%jed), source=0.0) - endif - endif - if (CS%do_sppt) then - CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', CS%diag%axesT1, Time, & - 'random pattern for sppt', 'None') + + if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) then + num_procs = num_PEs() + allocate(pelist(num_procs)) + call Get_PElist(pelist,commID = mom_comm) + pe_zero = root_PE() + nx = grid%iedB - grid%isdB + 1 + ny = grid%jedB - grid%jsdB + 1 + call init_stochastic_physics_ocn(dt,grid%geoLonBu,grid%geoLatBu,nx,ny,GV%ke, & + CS%pert_epbl,CS%do_sppt,CS%do_skeb,pe_zero,mom_comm,iret) + if (iret/=0) then + call MOM_error(FATAL, "call to init_stochastic_physics_ocn failed") + return + endif + + if (CS%do_sppt) allocate(CS%sppt_wts(grid%isdB:grid%iedB,grid%jsdB:grid%jedB)) + if (CS%do_skeb) allocate(CS%skeb_wts(grid%isdB:grid%iedB,grid%jsdB:grid%jedB)) + if (CS%do_skeb) allocate(CS%skeb_diss(grid%isd:grid%ied,grid%jsd:grid%jed,GV%ke), source=0.) + if (CS%pert_epbl) then + allocate(CS%epbl1_wts(grid%isdB:grid%iedB,grid%jsdB:grid%jedB)) + allocate(CS%epbl2_wts(grid%isdB:grid%iedB,grid%jsdB:grid%jedB)) + endif endif - if (CS%pert_epbl) then - CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', CS%diag%axesT1, Time, & - 'random pattern for KE generation', 'None') - CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', CS%diag%axesT1, Time, & - 'random pattern for KE dissipation', 'None') + + CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', CS%diag%axesB1, Time, & + 'random pattern for sppt', 'None') + CS%id_skeb_wts = register_diag_field('ocean_model', 'skeb_pattern', CS%diag%axesB1, Time, & + 'random pattern for skeb', 'None') + CS%id_epbl1_wts = register_diag_field('ocean_model', 'epbl1_wts', CS%diag%axesB1, Time, & + 'random pattern for KE generation', 'None') + CS%id_epbl2_wts = register_diag_field('ocean_model', 'epbl2_wts', CS%diag%axesB1, Time, & + 'random pattern for KE dissipation', 'None') + CS%id_skebu = register_diag_field('ocean_model', 'skebu', CS%diag%axesCuL, Time, & + 'zonal current perts', 'None') + CS%id_skebv = register_diag_field('ocean_model', 'skebv', CS%diag%axesCvL, Time, & + 'zonal current perts', 'None') + CS%id_diss = register_diag_field('ocean_model', 'skeb_amp', CS%diag%axesTL, Time, & + 'SKEB amplitude', 'm s-1') + CS%id_psi = register_diag_field('ocean_model', 'psi', CS%diag%axesBL, Time, & + 'stream function', 'None') + CS%id_skeb_taperu = register_static_field('ocean_model', 'skeb_taper_u', CS%diag%axesCu1, & + 'SKEB taper u', 'None', interp_method='none') + CS%id_skeb_taperv = register_static_field('ocean_model', 'skeb_taper_v', CS%diag%axesCv1, & + 'SKEB taper v', 'None', interp_method='none') + + ! Initialize the "taper" fields. These fields multiply the components of the stochastic + ! velocity increment in such a way as to smoothly taper them to zero at land boundaries. + if ((CS%do_skeb) .or. (CS%id_skeb_taperu > 0) .or. (CS%id_skeb_taperv > 0)) then + ALLOC_(CS%taperCu(grid%IsdB:grid%IedB,grid%jsd:grid%jed)) + ALLOC_(CS%taperCv(grid%isd:grid%ied,grid%JsdB:grid%JedB)) + ! Initialize taper from land mask + do j=grid%jsd,grid%jed ; do I=grid%isdB,grid%iedB + CS%taperCu(I,j) = grid%mask2dCu(I,j) + enddo ; enddo + do J=grid%jsdB,grid%jedB ; do i=grid%isd,grid%ied + CS%taperCv(i,J) = grid%mask2dCv(i,J) + enddo ; enddo + ! Extend taper land + do k=1,(taper_width / 2) + do j=grid%jsc-1,grid%jec+1 ; do I=grid%iscB-1,grid%iecB+1 + tmp(I,j) = minval(CS%taperCu(I-1:I+1,j-1:j+1)) + enddo ; enddo + do j=grid%jsc,grid%jec ; do I=grid%iscB,grid%iecB + CS%taperCu(I,j) = minval(tmp(I-1:I+1,j-1:j+1)) + enddo ; enddo + do J=grid%jscB-1,grid%jecB+1 ; do i=grid%isc-1,grid%iec+1 + tmp(i,J) = minval(CS%taperCv(i-1:i+1,J-1:J+1)) + enddo ; enddo + do J=grid%jscB,grid%jecB ; do i=grid%isc,grid%iec + CS%taperCv(i,J) = minval(tmp(i-1:i+1,J-1:J+1)) + enddo ; enddo + ! Update halo + call pass_vector(CS%taperCu, CS%taperCv, grid%Domain, SCALAR_PAIR) + enddo + ! Smooth tapers. Each call smooths twice. + do k=1,(taper_width - (taper_width/2)) + call smooth_x9_uv(grid, CS%taperCu, CS%taperCv, zero_land=.true.) + call pass_vector(CS%taperCu, CS%taperCv, grid%Domain, SCALAR_PAIR) + enddo endif - if (CS%do_sppt .OR. CS%pert_epbl) & + !call uvchksum("SKEB taper [uv]", CS%taperCu, CS%taperCv, grid%HI) + + if (CS%id_skeb_taperu > 0) call post_data(CS%id_skeb_taperu, CS%taperCu, CS%diag, .true.) + if (CS%id_skeb_taperv > 0) call post_data(CS%id_skeb_taperv, CS%taperCv, CS%diag, .true.) + + if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) & call MOM_mesg(' === COMPLETED MOM STOCHASTIC INITIALIZATION =====') - call callTree_leave("ocean_model_init(") + call callTree_leave("stochastic_init(), MOM_stochastics.F90") end subroutine stochastics_init @@ -138,10 +256,202 @@ subroutine update_stochastics(CS) call callTree_enter("update_stochastics(), MOM_stochastics.F90") ! update stochastic physics patterns before running next time-step - call run_stochastic_physics_ocn(CS%sppt_wts,CS%epbl1_wts,CS%epbl2_wts) + call run_stochastic_physics_ocn(CS%sppt_wts,CS%skeb_wts,CS%epbl1_wts,CS%epbl2_wts) + + call callTree_leave("update_stochastics(), MOM_stochastics.F90") - return end subroutine update_stochastics +subroutine apply_skeb(grid,GV,CS,uc,vc,thickness,tv,dt,Time_end) + + type(ocean_grid_type), intent(in) :: grid !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid + type(stochastic_CS), intent(inout) :: CS !< stochastic control structure + + real, dimension(SZIB_(grid),SZJ_(grid),SZK_(GV)), intent(inout) :: uc !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJB_(grid),SZK_(GV)), intent(inout) :: vc !< meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJ_(grid),SZK_(GV)), intent(in) :: thickness !< thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< points to thermodynamic fields + real, intent(in) :: dt !< time increment [T ~> s] + type(time_type), intent(in) :: Time_end !< Time at the end of the interval +! locals + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_,NKMEM_) :: psi + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: ustar + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: vstar + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: diss_tmp + + real, dimension(3,3) :: local_weights + + real :: shr,ten,tot,kh + integer :: i,j,k,iter + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + + call callTree_enter("apply_skeb(), MOM_stochastics.F90") + ALLOC_(diss_tmp(grid%isd:grid%ied,grid%jsd:grid%jed)) + ALLOC_(psi(grid%isdB:grid%iedB,grid%jsdB:grid%jedB,GV%ke)) + ALLOC_(ustar(grid%isdB:grid%iedB,grid%jsd:grid%jed,GV%ke)) + ALLOC_(vstar(grid%isd:grid%ied,grid%jsdB:grid%jedB,GV%ke)) + + if ((.not. CS%skeb_use_gm) .and. (.not. CS%skeb_use_frict)) then + ! fill in halos with zeros + do k=1,GV%ke + do j=grid%jsd,grid%jed ; do i=grid%isd,grid%ied + CS%skeb_diss(i,j,k) = 0.0 + enddo ; enddo + enddo + + !kh needs to be scaled + + kh=1!(120*111)**2 + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do i=grid%isc,grid%iec + ! Shear + shr = (vc(i,J,k)-vc(i-1,J,k))*grid%mask2dCv(i,J)*grid%mask2dCv(i-1,J)*grid%IdxCv(i,J)+& + (uc(I,j,k)-uc(I,j-1,k))*grid%mask2dCu(I,j)*grid%mask2dCu(I,j-1)*grid%IdyCu(I,j) + ! Tension + ten = (vc(i,J,k)-vc(i-1,J,k))*grid%mask2dCv(i,J)*grid%mask2dCv(i-1,J)*grid%IdyCv(i,J)+& + (uc(I,j,k)-uc(I,j-1,k))*grid%mask2dCu(I,j)*grid%mask2dCu(I,j-1)*grid%IdxCu(I,j) + + tot = sqrt( shr**2 + ten**2 ) * grid%mask2dT(i,j) + CS%skeb_diss(i,j,k) = tot**3 * kh * grid%areaT(i,j)!!**2 + enddo ; enddo + enddo + endif ! Sets CS%skeb_diss without GM or FrictWork + + ! smooth dissipation skeb_npass times + do iter=1,CS%skeb_npass + if (mod(iter,2) == 1) call pass_var(CS%skeb_diss, grid%domain) + do k=1,GV%ke + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + ! This does not preserve rotational symmetry + local_weights = grid%mask2dT(i-1:i+1,j-1:j+1)*grid%areaT(i-1:i+1,j-1:j+1) + diss_tmp(i,j) = sum(local_weights*CS%skeb_diss(i-1:i+1,j-1:j+1,k)) / & + (sum(local_weights) + 1.E-16) + enddo ; enddo + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + if (grid%mask2dT(i,j)==0.) cycle + CS%skeb_diss(i,j,k) = diss_tmp(i,j) + enddo ; enddo + enddo + enddo + call pass_var(CS%skeb_diss, grid%domain) + + ! call hchksum(CS%skeb_diss, "SKEB DISS", grid%HI, haloshift=2) + ! call qchksum(CS%skeb_wts, "SKEB WTS", grid%HI, haloshift=1) + + do k=1,GV%ke + do J=grid%jscB-1,grid%jecB ; do I=grid%iscB-1,grid%iecB + psi(I,J,k) = sqrt(0.25 * dt * max((CS%skeb_diss(i ,j ,k) + CS%skeb_diss(i+1,j+1,k)) + & + (CS%skeb_diss(i ,j+1,k) + CS%skeb_diss(i+1,j ,k)), 0.) ) & + * CS%skeb_wts(I,J) + enddo ; enddo + enddo + !call qchksum(psi,"SKEB PSI", grid%HI, haloshift=1) + !call pass_var(psi, grid%domain, position=CORNER) + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do I=grid%iscB,grid%iecB + ustar(I,j,k) = - (psi(I,J,k) - psi(I,J-1,k)) * CS%taperCu(I,j) * grid%IdyCu(I,j) + uc(I,j,k) = uc(I,j,k) + ustar(I,j,k) + enddo ; enddo + do J=grid%jscB,grid%jecB ; do i=grid%isc,grid%iec + vstar(i,J,k) = (psi(I,J,k) - psi(I-1,J,k)) * CS%taperCv(i,J) * grid%IdxCv(i,J) + vc(i,J,k) = vc(i,J,k) + vstar(i,J,k) + enddo ; enddo + enddo + + !call uvchksum("SKEB increment [uv]", ustar, vstar, grid%HI) + + call enable_averages(dt, Time_end, CS%diag) + if (CS%id_diss > 0) then + call post_data(CS%id_diss, sqrt(dt * max(CS%skeb_diss(:,:,:), 0.)), CS%diag) + endif + if (CS%id_skeb_wts > 0) then + call post_data(CS%id_skeb_wts, CS%skeb_wts, CS%diag) + endif + if (CS%id_skebu > 0) then + call post_data(CS%id_skebu, ustar(:,:,:), CS%diag) + endif + if (CS%id_skebv > 0) then + call post_data(CS%id_skebv, vstar(:,:,:), CS%diag) + endif + if (CS%id_psi > 0) then + call post_data(CS%id_psi, psi(:,:,:), CS%diag) + endif + call disable_averaging(CS%diag) + DEALLOC_(diss_tmp) + DEALLOC_(ustar) + DEALLOC_(vstar) + DEALLOC_(psi) + CS%skeb_diss(:,:,:) = 0.0 ! Must zero before next time step. + + call callTree_leave("apply_skeb(), MOM_stochastics.F90") + +end subroutine apply_skeb + +!> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve angular momentum, so don't use it +!! in situations where you need conservation. Also note that it assumes that the +!! input fields have valid values in the first two halo points upon entry. +subroutine smooth_x9_uv(G, field_u, field_v, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed[arbitrary] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + + ! Local variables. + real :: fu_prev(SZIB_(G),SZJ_(G)) ! The value of the u-point field at the previous iteration [arbitrary] + real :: fv_prev(SZI_(G),SZJB_(G)) ! The value of the v-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je, Isq, Ieq, Jsq, Jeq + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fu_prev(:,:) = field_u(:,:) + ! apply smoothing on field_u using rotationally symmetric expressions. + do j=js-s,je+s ; do I=Isq-s,Ieq+s ; if (G%mask2dCu(I,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCu(I,j) + & + ( 2.0*((G%mask2dCu(I-1,j) + G%mask2dCu(I+1,j)) + & + (G%mask2dCu(I,j-1) + G%mask2dCu(I,j+1))) + & + ((G%mask2dCu(I-1,j-1) + G%mask2dCu(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) + G%mask2dCu(I+1,j-1))) ) ) + 1.0e-16 ) + field_u(I,j) = Iwts * ( 4.0*G%mask2dCu(I,j) * fu_prev(I,j) & + + (2.0*((G%mask2dCu(I-1,j) * fu_prev(I-1,j) + G%mask2dCu(I+1,j) * fu_prev(I+1,j)) + & + (G%mask2dCu(I,j-1) * fu_prev(I,j-1) + G%mask2dCu(I,j+1) * fu_prev(I,j+1))) & + + ((G%mask2dCu(I-1,j-1) * fu_prev(I-1,j-1) + G%mask2dCu(I+1,j+1) * fu_prev(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) * fu_prev(I-1,j+1) + G%mask2dCu(I+1,j-1) * fu_prev(I-1,j-1))) )) + endif ; enddo ; enddo + + fv_prev(:,:) = field_v(:,:) + ! apply smoothing on field_v using rotationally symmetric expressions. + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s ; if (G%mask2dCv(i,J) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCv(i,J) + & + ( 2.0*((G%mask2dCv(i-1,J) + G%mask2dCv(i+1,J)) + & + (G%mask2dCv(i,J-1) + G%mask2dCv(i,J+1))) + & + ((G%mask2dCv(i-1,J-1) + G%mask2dCv(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) + G%mask2dCv(i+1,J-1))) ) ) + 1.0e-16 ) + field_v(i,J) = Iwts * ( 4.0*G%mask2dCv(i,J) * fv_prev(i,J) & + + (2.0*((G%mask2dCv(i-1,J) * fv_prev(i-1,J) + G%mask2dCv(i+1,J) * fv_prev(i+1,J)) + & + (G%mask2dCv(i,J-1) * fv_prev(i,J-1) + G%mask2dCv(i,J+1) * fv_prev(i,J+1))) & + + ((G%mask2dCv(i-1,J-1) * fv_prev(i-1,J-1) + G%mask2dCv(i+1,J+1) * fv_prev(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) * fv_prev(i-1,J+1) + G%mask2dCv(i+1,J-1) * fv_prev(i-1,J-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_uv + end module MOM_stochastics From 51a98c7c42511357deb2dc3a3b34e2e28693d143 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 10 Jul 2024 16:15:11 -0400 Subject: [PATCH 11/31] +Reproducing KPP_smooth_BLD when KPP%N_SMOOTH > 1 Revised KPP_smooth_BLD() to reproduce across processor count and layout when USE_KPP is true and KPP%N_SMOOTH > 1. The specific changes include adding a variable with the total ocean depth before doing the iterations, doing a halo update on this total ocean depth, marching in the working do-loop size with successive iterations, and moving the code to calculate CS%kOBL into a separate loop that is exercised after all of the iterations for the smoothing passes on CS%OBLdepth. This commit will change answers (so that they reproduce across processor count and layout) when USE_KPP is true and KPP%N_SMOOTH >= 2, but it gives bitwise identical answers when KPP%N_SMOOTH <= 1. --- .../vertical/MOM_CVMix_KPP.F90 | 83 +++++++++++++------ 1 file changed, 57 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8e95edd563..832d8bf4b1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -1342,47 +1342,60 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, dz) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer thicknesses [Z ~> m] - ! local + ! local variables real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)) :: total_depth ! The total depth of the water column, adjusted + ! for the minimum layer thickness [Z ~> m] real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] ! (negative in the ocean) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] ! (negative in the ocean) real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: h_cor(SZI_(G)) ! A cumulative correction arising from inflation of vanished layers [Z ~> m] real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] - integer :: i, j, k, s + integer :: i, j, k, s, halo call cpu_clock_begin(id_clock_KPP_smoothing) - ! Update halos + ! Find the total water column thickness first, as it is reused for each smoothing pass. + total_depth(:,:) = 0.0 + + !$OMP parallel do default(shared) private(dh, h_cor) + do j = G%jsc, G%jec + h_cor(:) = 0. + do k=1,GV%ke + do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.0) then + ! This code replicates the interface height calculations below. It could be simpler, as shown below. + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + h_cor(i) ! Take away the accumulated error (could temporarily make dh<0) + h_cor(i) = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + total_depth(i,j) = total_depth(i,j) + dh + endif ; enddo + enddo + enddo + ! A much simpler (but answer changing) version of the total_depth calculation would be + ! do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + ! total_depth(i,j) = total_depth(i,j) + dz(i,j,k) + ! enddo ; enddo ; enddo + + ! Update halos once, then march inward for each iteration + if (CS%n_smooth > 1) call pass_var(total_depth, G%Domain, halo=CS%n_smooth, complete=.false.) call pass_var(CS%OBLdepth, G%Domain, halo=CS%n_smooth) - if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original = CS%OBLdepth + if (CS%id_OBLdepth_original > 0) CS%OBLdepth_original(:,:) = CS%OBLdepth(:,:) do s=1,CS%n_smooth - OBLdepth_prev = CS%OBLdepth + OBLdepth_prev(:,:) = CS%OBLdepth(:,:) + halo = CS%n_smooth - s ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, US, CS, dz, OBLdepth_prev) & - !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) - do j = G%jsc, G%jec - do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then - - iFaceHeight(1) = 0.0 ! BBL is all relative to the surface - hcorr = 0. - do k=1,GV%ke - - ! cell center and cell bottom in meters (negative values in the ocean) - dh = dz(i,j,k) ! Nominal thickness to use for increment - dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) - hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh - enddo - + !$OMP parallel do default(none) shared(G, GV, CS, OBLdepth_prev, total_depth, halo) & + !$OMP private(wc, ww, we, wn, ws) + do j = G%jsc-halo, G%jec+halo + do i = G%isc-halo, G%iec+halo ; if (G%mask2dT(i,j) > 0.0) then ! compute weights ww = 0.125 * G%mask2dT(i-1,j) we = 0.125 * G%mask2dT(i+1,j) @@ -1400,19 +1413,37 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, dz) if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) ! prevent OBL depths deeper than the bathymetric depth - CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom - CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), total_depth(i,j) ) ! no deeper than bottom endif ; enddo enddo enddo ! s-loop + ! Determine the fractional index of the bottom of the boundary layer. + !$OMP parallel do default(none) shared(G, GV, CS, dz) & + !$OMP private(dh, hcorr, cellHeight, iFaceHeight) + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j) > 0.0) then + + iFaceHeight(1) = 0.0 ! BBL is all relative to the surface + hcorr = 0. + do k=1,GV%ke + ! cell center and cell bottom in meters (negative values in the ocean) + dh = dz(i,j,k) ! Nominal thickness to use for increment + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) + hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 + dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh + enddo + + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + endif ; enddo ; enddo + call cpu_clock_end(id_clock_KPP_smoothing) end subroutine KPP_smooth_BLD - !> Copies KPP surface boundary layer depth into BLD, in units of [Z ~> m] unless other units are specified. subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) type(KPP_CS), pointer :: CS !< Control structure for From 8a03b63c208f0f77fdeab4932d4d5ffd4fb0fee9 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 7 Jul 2024 06:09:16 -0600 Subject: [PATCH 12/31] append ensemble num to geom filename in ensemble runs --- src/initialization/MOM_shared_initialization.F90 | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 46d0448699..40e7661e7f 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -11,7 +11,7 @@ module MOM_shared_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, param_file_type, log_version -use MOM_io, only : create_MOM_file, file_exists, field_size +use MOM_io, only : create_MOM_file, file_exists, field_size, get_filename_appendix use MOM_io, only : MOM_infra_file, MOM_field use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, stdout use MOM_io, only : open_file_to_read, close_file_to_read, SINGLE_FILE, MULTIPLE @@ -1348,6 +1348,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) ! Local variables. character(len=240) :: filepath ! The full path to the file to write character(len=40) :: mdl = "write_ocean_geometry_file" + character(len=32) :: filename_appendix = '' ! Appendix to geom filename for ensemble runs type(vardesc), dimension(:), allocatable :: & vars ! Types with metadata about the variables and their staggering type(MOM_field), dimension(:), allocatable :: & @@ -1355,6 +1356,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset integer :: nFlds ! The number of variables in this file integer :: file_threading + integer :: geom_file_len ! geometry file name length logical :: multiple_files call callTree_enter('write_ocean_geometry_file()') @@ -1408,6 +1410,17 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) filepath = trim(directory) // "ocean_geometry" endif + ! Append ensemble run number to filename if it is an ensemble run + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + geom_file_len = len_trim(filepath) + if (filepath(geom_file_len-2:geom_file_len) == ".nc") then + filepath = filepath(1:geom_file_len-3) // '.' // trim(filename_appendix) // ".nc" + else + filepath = filepath // '.' // trim(filename_appendix) + endif + endif + call get_param(param_file, mdl, "PARALLEL_RESTARTFILES", multiple_files, & "If true, the IO layout is used to group processors that write to the same "//& "restart file or each processor writes its own (numbered) restart file. "//& From 99edf23b0e22e96ff22eccb79f11e223fe0c23d1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 13 Jul 2024 12:04:39 -0400 Subject: [PATCH 13/31] *+Make Leith viscosity runs layout-invariant Added the new function hor_visc_vel_stencil to return the velocity stencil of the velocity fields used by horizontal_viscosity depending on the options that are in use, and then use this information in the group_pass calls for the velocities that are passed to horizontal_viscosity. Also adjusted the size of the loops used to set up DX_dyBu and DY_dxBu in the hor_visc control structure depending on the horizontal viscosity options and added a test in hor_visc_init for a large enough halo size for the options that are in use. Both of these answer-changing modifications are necessary for MOM6 to reproduce across PE count and layout) when Leith viscosity parameterizations are in use. The MOM_hor_visc code was also revised slightly in several places to more closely adhere to MOM6 style with respect to using a 2-point indent and similar purely cosmetic considerations. This commit does change answers when a Leith viscosity is in use, and adds a new publicly visible function. Answers are bitwise identical when a Leith viscosity is not being used. --- src/core/MOM_dynamics_split_RK2.F90 | 15 ++-- .../lateral/MOM_hor_visc.F90 | 75 +++++++++++++------ 2 files changed, 59 insertions(+), 31 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 4bbd03a46a..14b0942009 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -48,7 +48,7 @@ module MOM_dynamics_split_RK2 use MOM_debugging, only : check_redundant use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS, hor_visc_vel_stencil use MOM_hor_visc, only : hor_visc_init, hor_visc_end use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV use MOM_lateral_mixing_coeffs, only : VarMix_CS @@ -401,7 +401,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s logical :: showCallTree, sym integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: cont_stencil, obc_stencil + integer :: cont_stencil, obc_stencil, vel_stencil is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -468,19 +468,20 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (associated(CS%OBC)) then if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 endif + vel_stencil = max(2, obc_stencil, hor_visc_vel_stencil(CS%hor_visc)) call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=vel_stencil) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil) call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=vel_stencil) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=vel_stencil) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -841,7 +842,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call MOM_state_chksum("Predictor ", up, vp, hp, uh, vh, G, GV, US, symmetric=sym) - call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=vel_stencil, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_MKS) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) call check_redundant("Predictor up ", up, vp, G, unscale=US%L_T_to_m_s) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d59e6b3871..6d188990a1 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -31,7 +31,7 @@ module MOM_hor_visc #include -public horizontal_viscosity, hor_visc_init, hor_visc_end +public horizontal_viscosity, hor_visc_init, hor_visc_end, hor_visc_vel_stencil !> Control structure for horizontal viscosity type, public :: hor_visc_CS ; private @@ -1198,10 +1198,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh AhSm = Shear_mag(i,j) * (CS%Biharm_const_xx(i,j) & - + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j) & - ) + + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j)) Ah(i,j) = max(Ah(i,j), AhSm) enddo ; enddo else @@ -1432,10 +1431,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Pass the velocity gradients and thickness to ZB2020 if (CS%use_ZB2020) then - call ZB2020_copy_gradient_and_thickness( & - sh_xx, sh_xy, vort_xy, & - hq, & - G, GV, CS%ZB2020, k) + call ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, G, GV, CS%ZB2020, k) endif if (CS%Laplacian) then @@ -1575,8 +1571,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%bound_Coriolis) then do J=js-1,Jeq ; do I=is-1,Ieq AhSm = Shear_mag(I,J) * (CS%Biharm_const_xy(I,J) & - + CS%Biharm_const2_xy(I,J) * Shear_mag(I,J) & - ) + + CS%Biharm_const2_xy(I,J) * Shear_mag(I,J)) Ah(I,J) = max(Ah(I,J), AhSm) enddo ; enddo else @@ -1605,8 +1600,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! *Add* the MEKE contribution do J=js-1,Jeq ; do I=is-1,Ieq Ah(I,J) = Ah(I,J) + 0.25 * ( & - (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) & - ) + (MEKE%Au(i,j) + MEKE%Au(i+1,j+1)) + (MEKE%Au(i+1,j) + MEKE%Au(i,j+1)) ) enddo ; enddo endif @@ -1897,11 +1891,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%debug) then if (CS%Laplacian) then + ! In symmetric memory mode, Kh_h should also be valid with a haloshift of 1. call hchksum(Kh_h, "Kh_h", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) - call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, scale=US%L_to_m**2*US%s_to_T) + call Bchksum(Kh_q, "Kh_q", G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2*US%s_to_T) + endif + if (CS%biharmonic) then + ! In symmetric memory mode, Ah_h should also be valid with a haloshift of 1. + call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) + call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**4*US%s_to_T) endif - if (CS%biharmonic) call hchksum(Ah_h, "Ah_h", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) - if (CS%biharmonic) call Bchksum(Ah_q, "Ah_q", G%HI, haloshift=0, scale=US%L_to_m**4*US%s_to_T) endif if (CS%id_FrictWorkIntz > 0) then @@ -2403,14 +2401,31 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%m_leithy_max(isd:ied,jsd:jed)) ; CS%m_leithy_max(:,:) = 0.0 endif if (CS%Re_Ah > 0.0) then - ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 - ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)); CS%Re_Ah_const_xy(:,:) = 0.0 + ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)) ; CS%Re_Ah_const_xx(:,:) = 0.0 + ALLOC_(CS%Re_Ah_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%Re_Ah_const_xy(:,:) = 0.0 endif endif do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) - CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) enddo ; enddo + + if (((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) .and. & + ((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3))) call MOM_error(FATAL, & + "The minimum halo size is 3 when a Leith viscosity is being used.") + if (CS%use_Leithy) then + do J=js-3,Jeq+2 ; do I=is-3,Ieq+2 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + elseif ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) + enddo ; enddo + endif + do j=js-2,Jeq+2 ; do i=is-2,Ieq+2 CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) @@ -2541,12 +2556,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) endif endif if (CS%Leith_Ah) then - CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) + CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) endif if (CS%use_Leithy) then - CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 - CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) - CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 + CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 + CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) + CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah @@ -2571,12 +2586,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) endif endif if ((CS%Leith_Ah) .or. (CS%use_Leithy))then - CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) + CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xy(i,j) = grid_sp_q3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xy(i,j) = & - MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) + MAX(CS%Ah_bg_xy(i,j), (grid_sp_q2 * grid_sp_q2) / Ah_time_scale) if (CS%bound_Ah .and. .not.CS%better_bound_Ah) then CS%Ah_Max_xy(I,J) = Ah_Limit * (grid_sp_q2 * grid_sp_q2) CS%Ah_bg_xy(I,J) = MIN(CS%Ah_bg_xy(I,J), CS%Ah_Max_xy(I,J)) @@ -2822,6 +2837,18 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) end subroutine hor_visc_init +!> hor_visc_vel_stencil returns the horizontal viscosity input velocity stencil size +function hor_visc_vel_stencil(CS) result(stencil) + type(hor_visc_CS), intent(in) :: CS !< Control structure for horizontal viscosity + integer :: stencil !< The horizontal viscosity velocity stencil size with the current settings. + + stencil = 2 + + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + stencil = 3 + endif +end function hor_visc_vel_stencil + !> Calculates factors in the anisotropic orientation tensor to be align with the grid. !! With n1=1 and n2=0, this recovers the approach of Large et al, 2001. subroutine align_aniso_tensor_to_grid(CS, n1, n2) From 9ff6ca419265b275e697e2724af8911385222d5a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 14 Jul 2024 15:32:17 -0400 Subject: [PATCH 14/31] Scale checksums in hor_bnd_diffusion Added missing scale arguments to the hchksum and global_mass_integral calls for debugging in hor_bnd_diffusion, so that they now give messages to stdout that do not change when tracers (including temperature and salinity) are rescaled. Also added a missing debuggingParam argument to the get_Param call for HBD_DEBUG so that is will be logged in MOM_parameter_doc.debugging rather that MOM_parameter_doc.all. This commit partially addresses the scaling problems that were noted in github.com/NCAR/MOM6/issues/275. All solutions are bitwise identical, but some debugging output can change to become more robust. --- src/tracer/MOM_hor_bnd_diffusion.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 4f6f198ff8..5b9af238d6 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -32,7 +32,7 @@ module MOM_hor_bnd_diffusion public boundary_k_range, hor_bnd_diffusion_end ! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface boundary integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include @@ -146,10 +146,11 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "DEBUG", debug, & + default=.false., debuggingParam=.true., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & "If true, write out verbose debugging data in the HBD module.", & - default=debug) + default=debug, debuggingParam=.true.) id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) @@ -208,7 +209,7 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) tracer => Reg%tr(m) if (CS%debug) then - call hchksum(tracer%t, "before HBD "//tracer%name,G%HI) + call hchksum(tracer%t, "before HBD "//tracer%name, G%HI, scale=tracer%conc_scale) endif ! for diagnostics @@ -264,10 +265,10 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif if (CS%debug) then - call hchksum(tracer%t, "after HBD "//tracer%name,G%HI) + call hchksum(tracer%t, "after HBD "//tracer%name, G%HI, scale=tracer%conc_scale) ! tracer (native grid) integrated tracer amounts before and after HBD - tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) - tracer_int_end = global_mass_integral(h, G, GV, tracer%t) + tracer_int_prev = global_mass_integral(h, G, GV, tracer_old, scale=tracer%conc_scale) + tracer_int_end = global_mass_integral(h, G, GV, tracer%t, scale=tracer%conc_scale) write(mesg,*) 'Total '//tracer%name//' before/after HBD:', tracer_int_prev, tracer_int_end call MOM_mesg(mesg) endif @@ -1213,7 +1214,7 @@ end subroutine hor_bnd_diffusion_end !! !! \subsection section_harmonic_mean Harmonic Mean !! -!! The harmonic mean (HM) betwen h1 and h2 is defined as: +!! The harmonic mean (HM) between h1 and h2 is defined as: !! !! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] !! From e413c299d190254967b18922b682f2d797405810 Mon Sep 17 00:00:00 2001 From: fobryan3 <47898629+fobryan3@users.noreply.github.com> Date: Wed, 31 Jul 2024 10:35:31 -0600 Subject: [PATCH 15/31] Adding Ohlmann solar penetration scheme to MOM_opacity (#289) * Adding Ohlmann solar pentration scheme to MOM_optics * Fixed some violations of code style guide * Fixing a few more code style violations * Fixing yet another code style guide violation * Cleaned up some coment statements. No changes to code. * Fixed formatting of string in get_param. Cleaned up extraneous FOB footprints in comments * Fix spelling (Ohlman to Ohlmann) --------- Co-authored-by: Gustavo Marques --- .../vertical/MOM_opacity.F90 | 258 +++++++++++++++++- 1 file changed, 250 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 61a7a0c7d0..831607d2db 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -40,7 +40,18 @@ module MOM_opacity real :: PenSW_flux_absorb !< A heat flux that is small enough to be completely absorbed in the next !! sufficiently thick layer [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. real :: PenSW_absorb_Invlen !< The inverse of the thickness that is used to absorb the remaining - !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. + !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. + + !! Lookup tables for Ohlmann solar penetration scheme + !! These would naturally exist as private module variables but that is prohibited in MOM6 + real :: dlog10chl !< Chl increment within lookup table + real :: log10chl_min !< Lower bound of Chl in lookup table + real :: log10chl_max !< Upper bound of Chl in lookup table + real, allocatable, dimension(:) :: a1_lut,& !< Coefficient for band 1 + & a2_lut,& !< Coefficient for band 2 + & b1_lut,& !< Exponential decay scale for band 1 + & b2_lut !< Exponential decay scale for band 2 + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the optics !! calculations. Values below 20190101 recover the answers from the !! end of 2018, while higher values use updated and more robust @@ -77,11 +88,13 @@ module MOM_opacity end type opacity_CS !>@{ Coded integers to specify the opacity scheme -integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4 +integer, parameter :: NO_SCHEME = 0, MANIZZA_05 = 1, MOREL_88 = 2, SINGLE_EXP = 3, DOUBLE_EXP = 4,& + & OHLMANN_03 = 5 !>@} character*(10), parameter :: MANIZZA_05_STRING = "MANIZZA_05" !< String to specify the opacity scheme character*(10), parameter :: MOREL_88_STRING = "MOREL_88" !< String to specify the opacity scheme +character*(10), parameter :: OHLMANN_03_STRING = "OHLMANN_03" !< String to specify the opacity scheme character*(10), parameter :: SINGLE_EXP_STRING = "SINGLE_EXP" !< String to specify the opacity scheme character*(10), parameter :: DOUBLE_EXP_STRING = "DOUBLE_EXP" !< String to specify the opacity scheme @@ -254,6 +267,16 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir ! use the "blue" band in the parameterizations to determine the e-folding ! depth of the incoming shortwave attenuation. The red portion is lumped ! into the net heating at the surface. +! Adding Ohlmann scheme. Needs sw_total and chl as inputs. Produces 2 penetrating bands. +! This implementation follows that in CESM-POP using a lookup table in log10(chl) space. +! The table is initialized in subroutine init_ohlmann and the coefficients are recovered +! with routines lookup_ohlmann_swpen and lookup_ohlmann_opacity. +! Note that this form treats the IR solar input implicitly: the sum of partioning +! coefficients < 1.0. The remainder is non-penetrating and is deposited in first layer +! irrespective of thickness. The Ohlmann (2003) paper states that the scheme is not valid +! for vertcal grids with first layer thickness < 2.0 meters. +! +! Ohlmann, J.C. Ocean radiant heating in climate models. J. Climate, 16, 1337-1351, 2003. ! ! Morel, A., Optical modeling of the upper ocean in relation to its biogenous ! matter content (case-i waters)., J. Geo. Res., {93}, 10,749--10,768, 1988. @@ -353,13 +376,44 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir do n=1,nbands optics%sw_pen_band(n,i,j) = Inv_nbands*sw_pen_tot enddo - enddo ; enddo + enddo; enddo + case (OHLMANN_03) + ! want exactly two penetrating bands. If not, throw an error. + if ( nbands /= 2 ) then + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme requires nbands==2.") + endif + !$OMP parallel do default(shared) private(SW_vis_tot) + do j=js,je ; do i=is,ie + SW_vis_tot = 0.0 ! Ohlmann does not classify as vis/nir. Using vis to add up total + if (G%mask2dT(i,j) < 0.5) then + optics%sw_pen_band(1:2,i,j) = 0. ! Make sure there is a valid value for land points + else + if (multiband_vis_input ) then ! If multiband_vis_input is true then so is multiband_nir_input + SW_vis_tot = sw_vis_dir(i,j) + sw_vis_dif(i,j) + & + & sw_nir_dir(i,j) + sw_nir_dif(i,j) + elseif (total_sw_input) then + SW_vis_tot = sw_total(i,j) + else + call MOM_error(FATAL, "No shortwave input was provided.") + endif + + ! Bands 1-2 (Ohlmann factors A with coefficients for Table 1a) + optics%sw_pen_band(1:2,i,j) = lookup_ohlmann_swpen(chl_data(i,j),optics)*SW_vis_tot + endif + enddo; enddo case default call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select !$OMP parallel do default(shared) firstprivate(chl_data) do k=1,nz + !! FOB + !!! I don't think this is what we want to do with Ohlmann. + !!! The surface CHL is used in developing the parameterization. + !!! Only the surface CHL is used above in setting optics%sw_pen_band for all schemes. + !!! Seems inconsistent to use depth dependent CHL in opacity calculation. + !!! Nevertheless, leaving as is for now. + !! FOB if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,k) ; enddo ; enddo endif @@ -389,14 +443,22 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir do n=2,optics%nbands optics%opacity_band(n,i,j,k) = optics%opacity_band(1,i,j,k) enddo - enddo ; enddo - + enddo; enddo + case (OHLMANN_03) + !! not testing for 2 bands since we did it above + do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) <= 0.5) then + optics%opacity_band(1:2,i,j,k) = CS%opacity_land_value + else + ! Bands 1-2 (Ohlmann factors B with coefficients for Table 1a + optics%opacity_band(1:2,i,j,k) = lookup_ohlmann_opacity(chl_data(i,j),optics) * US%Z_to_m + endif + enddo; enddo case default call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select enddo - end subroutine opacity_from_chl !> This sets the blue-wavelength opacity according to the scheme proposed by @@ -998,7 +1060,8 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) "concentrations are translated into opacities. Currently "//& "valid options include:\n"//& " \t\t MANIZZA_05 - Use Manizza et al., GRL, 2005. \n"//& - " \t\t MOREL_88 - Use Morel, JGR, 1988.", & + " \t\t MOREL_88 - Use Morel, JGR, 1988. \n"//& + " \t\t OHLMANN_03 - Use Ohlmann, J Clim, 2003.", & default=MANIZZA_05_STRING) if (len_trim(tmpstr) > 0) then tmpstr = uppercase(tmpstr) @@ -1007,6 +1070,8 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) CS%opacity_scheme = MANIZZA_05 ; scheme_string = MANIZZA_05_STRING case (MOREL_88_STRING) CS%opacity_scheme = MOREL_88 ; scheme_string = MOREL_88_STRING + case (OHLMANN_03_STRING) + CS%opacity_scheme = OHLMANN_03 ; scheme_string = OHLMANN_03_STRING case default call MOM_error(FATAL, "opacity_init: #DEFINE OPACITY_SCHEME "//& trim(tmpstr) // "in input file is invalid.") @@ -1072,6 +1137,9 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) elseif (CS%Opacity_scheme == SINGLE_EXP ) then if (optics%nbands /= 1) call MOM_error(FATAL, & "set_opacity: \Cannot use a single_exp opacity scheme with nbands!=1.") + elseif (CS%Opacity_scheme == OHLMANN_03 ) then + if (optics%nbands /= 2) call MOM_error(FATAL, & + "set_opacity: \OHLMANN_03 scheme requires nbands==2") endif call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & @@ -1143,8 +1211,175 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) longname, 'm-1', conversion=US%m_to_Z) enddo + !! FOB + if (CS%opacity_scheme == OHLMANN_03) then + ! Set up the lookup table + call init_ohlmann_table(optics) + endif + !! FOB + end subroutine opacity_init +!> Initialize the lookup table for Ohlmann solar penetration scheme. +!! Step size in Chl is a constant in log-space to make lookups easy. +!! Step size is fine enough that nearest neighbor lookup is sufficiently +!! accurate. +subroutine init_ohlmann_table(optics) + + implicit none + + type(optics_type), intent(inout) :: optics + + ! Local variables + + !! These are the data from Ohlmann (2003) Table 1a with additional + !! values provided by C. Ohlmann and implemented in CESM-POP by B. Briegleb + integer, parameter :: nval_tab1a = 31 + real, parameter, dimension(nval_tab1a) :: & + chl_tab1a = (/ & + .001, .005, .01, .02, & + .03, .05, .10, .15, & + .20, .25, .30, .35, & + .40, .45, .50, .60, & + .70, .80, .90, 1.00, & + 1.50, 2.00, 2.50, 3.00, & + 4.00, 5.00, 6.00, 7.00, & + 8.00, 9.00, 10.00 /) + + real, parameter, dimension(nval_tab1a) :: & + a1_tab1a = (/ & + 0.4421, 0.4451, 0.4488, 0.4563, & + 0.4622, 0.4715, 0.4877, 0.4993, & + 0.5084, 0.5159, 0.5223, 0.5278, & + 0.5326, 0.5369, 0.5408, 0.5474, & + 0.5529, 0.5576, 0.5615, 0.5649, & + 0.5757, 0.5802, 0.5808, 0.5788, & + 0.56965, 0.55638, 0.54091, 0.52442, & + 0.50766, 0.49110, 0.47505 /) + + real, parameter, dimension(nval_tab1a) :: & + a2_tab1a = (/ & + 0.2981, 0.2963, 0.2940, 0.2894, & + 0.2858, 0.2800, 0.2703, 0.2628, & + 0.2571, 0.2523, 0.2481, 0.2444, & + 0.2411, 0.2382, 0.2356, 0.2309, & + 0.2269, 0.2235, 0.2206, 0.2181, & + 0.2106, 0.2089, 0.2113, 0.2167, & + 0.23357, 0.25504, 0.27829, 0.30274, & + 0.32698, 0.35056, 0.37303 /) + + real, parameter, dimension(nval_tab1a) :: & + b1_tab1a = (/ & + 0.0287, 0.0301, 0.0319, 0.0355, & + 0.0384, 0.0434, 0.0532, 0.0612, & + 0.0681, 0.0743, 0.0800, 0.0853, & + 0.0902, 0.0949, 0.0993, 0.1077, & + 0.1154, 0.1227, 0.1294, 0.1359, & + 0.1640, 0.1876, 0.2082, 0.2264, & + 0.25808, 0.28498, 0.30844, 0.32932, & + 0.34817, 0.36540, 0.38132 /) + + real, parameter, dimension(nval_tab1a) :: & + b2_tab1a = (/ & + 0.3192, 0.3243, 0.3306, 0.3433, & + 0.3537, 0.3705, 0.4031, 0.4262, & + 0.4456, 0.4621, 0.4763, 0.4889, & + 0.4999, 0.5100, 0.5191, 0.5347, & + 0.5477, 0.5588, 0.5682, 0.5764, & + 0.6042, 0.6206, 0.6324, 0.6425, & + 0.66172, 0.68144, 0.70086, 0.72144, & + 0.74178, 0.76190, 0.78155 /) + + !! Make the table big enough so step size is smaller + !! in log-space that any increment in Table 1a + integer, parameter :: nval_lut=401 + real :: chl, log10chl_lut, w1, w2 + integer :: n,m,mm1,err + + allocate(optics%a1_lut(nval_lut),optics%b1_lut(nval_lut),& + & optics%a2_lut(nval_lut),optics%b2_lut(nval_lut),& + & stat=err) + if ( err /= 0 ) then + call MOM_error(FATAL,"init_ohlmann: Cannot allocate lookup table") + endif + + optics%log10chl_min = log10(chl_tab1a(1)) + optics%log10chl_max = log10(chl_tab1a(nval_tab1a)) + optics%dlog10chl = (optics%log10chl_max - optics%log10chl_min)/(nval_lut-1) + + ! step through the lookup table + m = 2 + do n=1,nval_lut + log10chl_lut = optics%log10chl_min + (n-1)*optics%dlog10chl + chl = 10.0**log10chl_lut + chl = max(chl_tab1a(1),min(chl,chl_tab1a(nval_tab1a))) + + ! find interval in Table 1a (m-1,m] + do while (chl > chl_tab1a(m)) + m = m + 1 + enddo + mm1 = m-1 + + ! interpolation weights + w2 = (chl - chl_tab1a(mm1))/(chl_tab1a(m) - chl_tab1a(mm1)) + w1 = 1. - w2 + + ! fill in the tables + optics%a1_lut(n) = w1*a1_tab1a(mm1) + w2*a1_tab1a(m) + optics%a2_lut(n) = w1*a2_tab1a(mm1) + w2*a2_tab1a(m) + optics%b1_lut(n) = w1*b1_tab1a(mm1) + w2*b1_tab1a(m) + optics%b2_lut(n) = w1*b2_tab1a(mm1) + w2*b2_tab1a(m) + enddo + + return +end subroutine init_ohlmann_table + +!> Get the partion of total solar into bands from Ohlmann lookup table +function lookup_ohlmann_swpen(chl,optics) result(A) + + implicit none + + real, intent(in) :: chl + type(optics_type), intent(in) :: optics + real, dimension(2) :: A + + ! Local variables + + real :: log10chl + integer :: n + + ! Make sure we are in the table + log10chl = max(optics%log10chl_min,min(log10(chl),optics%log10chl_max)) + ! Do a nearest neighbor lookup + n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 + + A(1) = optics%a1_lut(n) + A(2) = optics%a2_lut(n) + +end function lookup_ohlmann_swpen + +!> Get the opacity (decay scale) from Ohlmann lookup table +function lookup_ohlmann_opacity(chl,optics) result(B) + + implicit none + real, intent(in) :: chl + type(optics_type), intent(in) :: optics + real, dimension(2) :: B + + ! Local variables + real :: log10chl + integer :: n + + ! Make sure we are in the table + log10chl = max(optics%log10chl_min,min(log10(chl),optics%log10chl_max)) + ! Do a nearest neighbor lookup + n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 + + B(1) = optics%b1_lut(n) + B(2) = optics%b2_lut(n) + + return +end function lookup_ohlmann_opacity subroutine opacity_end(CS, optics) type(opacity_CS) :: CS !< Opacity control structure @@ -1159,7 +1394,11 @@ subroutine opacity_end(CS, optics) if (allocated(optics%max_wavelength_band)) & deallocate(optics%max_wavelength_band) if (allocated(optics%min_wavelength_band)) & - deallocate(optics%min_wavelength_band) + deallocate(optics%min_wavelength_band) + if (allocated(optics%a1_lut)) deallocate(optics%a1_lut) + if (allocated(optics%a2_lut)) deallocate(optics%a2_lut) + if (allocated(optics%b1_lut)) deallocate(optics%b1_lut) + if (allocated(optics%b2_lut)) deallocate(optics%b2_lut) end subroutine opacity_end !> \namespace mom_opacity @@ -1179,4 +1418,7 @@ end subroutine opacity_end !! and sea-ice in a global model, Geophys. Res. Let., 32, L05603, !! doi:10.1029/2004GL020778. +!! Ohlmann, J.C., 2003: Ocean radiant heating in climate models. +!! J. Climate, 16, 1337-1351, 2003. + end module MOM_opacity From 8b9ba9767e4c28d33800117f6abcaf2e9f4b516d Mon Sep 17 00:00:00 2001 From: Michael Levy Date: Fri, 2 Aug 2024 11:52:28 -0600 Subject: [PATCH 16/31] Add MARBL to MOM6 (#157) * Update MOM6_DA_hooks submodule * Create a placeholder MARBL tracer module Copied dye_example.F90, renamed all public routines. This module does not actually tie into MARBL at this time. * Add flag to turn on MARBL tracers Adding USE_MARBL_TRACERS = True to override file turns on MARBL tracers. At this point, we call marbl_instances%init and register all 32 tracers but don't do anything else (so they are initialized to 0 and there is no source term for advecting them yet) * Add MARBL as submodule CESM will use MARBL via manage_externals, but other systems may need to bring it in via submodules * Add doxygen documentation to marbl_instances * Update submodules to use https not ssh * Softlink to MARBL source code I think this is just needed for TravisCI, since it doesn't know to look for code in pkg/ * Remove diag_to_Z_CS This looks like it was removed from everywhere else when I merged in the latest dev/ncar branch * Move MARBL%init out of register_MARBL_tracers Created new configure_MARBL_tracers() subroutine to be called from call_tracer_register() [between get_param() calls and register_* calls] * Read marbl_in from run directory Also uses put_settings() to update the MARBL settings before initialization (tested by setting ciso_on = .true. via user_nl_marbl) * Add ability to write MARBL log to stdout marbl_instance%StatusLog is written after the call to init and in marbl_tracers_end (which is now called from tracer_flow_control_end()) * Add doxygen documentation for print_marbl_log() Failed a TravisCI test due to missing documentation * Call MARBL's shutdown() routine Also added a placeholder for parsing the MARBL timing information * Erase MARBL log after printing to stdout Every call to print_marbl_log() is followed by a call to %erase() * Read in MARBL tracers IC file Instead of passively advecting 0s, the MARBL_tracers module now correctly initializes each tracer (but doesn't compute any source-sink terms yet) * Update MARBL to latest development commit Went from 0a806cf to 479f914 * Change git submodule commit for MOM6_DA_hooks * Make configure_MARBL_tracers() private call the function from register_MARBL_tracers() rather than MOM_tracer_flow_control. * Removed MARBL as submodule MARBL will be brought in to CESM via manage_externals, and we will use -DUSE_MARBL_TRACERS to build with access to MARBL. * Add pkg/MARBL to .gitignore Now that it comes in from manage_externals, we want to ignore it * Introduce _USE_MARBL_TRACERS macro Can build MOM without pkg/MARBL, but if USE_MARBL_TRACERS is True in the param file and the build does not include -D_USE_MARBL_TRACERS then the model aborts. * Register MARBL diagnostics Will allow MARBL diagnostics to be added to history files. * call MARBL_tracers_surface_state() And, from that routine, call marbl_instances%surface_flux_compute(). Note that forcings, surface tracers, and surface fluxes are all zeroed out in this commit. I'd like to get diagnostics posted in the next commit, and then I can start updating tracer surface values, saving saved state, and looking into how to read forcing fields. * Move call to surface_flux_compute() Looks like column_physics() is the better place for this call * add surface flux diags to history output calls post_data (note that created a temporary data structure to hold both the diagnostic id and a buffer to fill column-by-column as MARBL runs) * Initialize surface flux forcings better During configuration, set indices for each of the surface flux forcings so that each forcing can be set to a different value in column_physics(); all are set to zero except u10_sqr (2.5e5), atmpress (1), and xco2 / xco2_alt_co2 (284.7) * Move module memory into CS type * Provide T & S for surface forcing Also, cleaned out remnants of old dye_tracer code * Add saved state for surface fluxes * Get ice fraction from the coupler * Get u10_sqr from coupler Also updated how a few other forcing fields are passed * Clean up old comment * Better unit conversion * Module parameters for unit conversion MARBL still wants things in cgs, so the conversion factors are private in the MARBL_tracers module * Easy clean-up based on feedback from Andrew * Add missing variable declaration * Add saved state to restart file * Add surface flux to tracer_vertdiff call * If tracers mandatory in restart, so is saved state Also, playing around with some debugging diagnostic output because it appears that register_restart() isn't actually updating the field values (saved state is initialized to 0 even when available in saved state) * Move call to setup_saved_state() It needs to be in the tracer_registry stage, not the initialize_tracers stage so that fields will be updated from the restart file. * Get dust and iron fluxes from coupler computes iron flux from dust and black carbon fluxes, adding some new variables to parameter file * Add option to read NDEP from a file Also, only call surface_flux_compute() from ocean cells * Update NDEP scale factor, work to interior_tend 1. Stale change that I forgot to commit earlier this month about how we apply scale factor to NDEP forcing 2. Starting to put in calls that will be necessary prior to calling interior_tendency_compute() [copying saved state, getting forcing fields, setting up domain, etc] * More support for interior_tendency_compute() call Still don't actually make the call, but I register interior tendency diagnostics and hopefully have all the data copies set up properly. * Update MARBL domain per-column In loop that will eventually call interior_tendency_compute(), update domain%zw, domain%delta_z, and domain%zt to get depths in m (and then convert to cm when copying to MARBL structure) * Add indices for interior tendency forcings Note that this commit does not support tracer restoring; that is disabled in a temporary block of code after reading marbl_in. * Copy t & s -> interior_tendency_forcing * Call marbl_interior_tendency_compute() There's a kludgy work-around where we set KMT to be the bottom-most level that is more than 1 cm thick (to avoid sediment from accumulating in vanishing layers) and we still don't read iron sediment flux * Add parameters to read in fe sed / vent fluxes Read in (and do unit conversion) for fesedflux and feventflux as part of initialization. Still need to figure out the vertical remap inside the time step loop. * Get FESEDFLUX into MARBL Use reintegrate_column() to map fesedflux from WOA z-grid to whatever vertical levels MOM6 is using at the current time step. This is a very kludgy commit! 1. Loop through all levels (from bottom to top) and move any subsurface sediment flux up a level. The way the loop is ordered results in all subsurface flux ending up in the bottom-most layer. [On the source grid, so vanishing layers are not a concern.] 1. I created a 3D array to store the WOA vertical thicknesses, except I modified the thickness of the cell containing the bottom of the column (G%bathyT) to only be distance from the cell interface to bathyT, and the thickness of all cells below it are 0. This is the kludgy part of the commit. 2. apply a dilation factor of sum(thickness)/bathyT to the thicknesses of the source grid, so we are effectively always mapping between two columns of the same thickness. * Had a few issues in last commit 1. read_z_edges returns depths that are 0 at surface and positive UP; algorithm I was using assumed positive DOWN 2. the logic in determining dz was hard to follow, so I rewrote the if statements to make it clearer 3. use dz(:) rather than marbl_instance%domain%delta_z to keep MOM units * Use time_interp_external() not MOM_read_data() This is just for reading nitrogen deposition, and it relies on FMS to handle time interpolation for climatological forcing. * Add surface_flux and tendency to diagnostic output For now I use the POP naming convention of STF_{tracer} and J_{tracer} * Fix bug in units of z-coordinate vars Was trying to convert MOM's variables in units of m to MARBL's desired units of cm by multiplying by 0.01 instead of 100 * Remove _USE_MARBL_TRACERS CPP macro Copying the changes to generic_tracers, there are now stubs for the MARBL API in config_src/external/MARBL so if pkg/MARBL is not available users can still build MOM. Note that these stubs will trigger cause MOM to abort if they are run with USE_MARBL_TRACERS=True in the parameters file. * Update ndep file Use a file with _FillValue=-1e34 rather than a file with NaNs * Ignore levels below kmt from marbl_instance object Since we are ignoring vanishingly thin layers at the bottom of the column when passing data into MARBL, we also need to ignore what MARBL returns from those levels. Now all tendency and diagnostic values for k>kmt are replaced with the value from the kmt level. I also replace saved state below kmt with 0s though I suppose an argument could be made for using the kmt value there as well * Refactor where MARBL forcings are defined Introduced marbl_forcing_type, and fluxes%MARBL_forcings of that type. Also introduced marbl_forcing_CS to handle all the parameter settings. Both of these changes are aimed at reducing the footprint of the changes in config_src/mct_driver needed to run MARBL; that will make it easier to bring the same changes to config_src/nuopc_driver. I think the last big change will be to create marbl_ice_ocean_boundary_type and a function to make it easy to copy data from the new type into marbl_forcing_type. * Finish refactoring mct driver All MARBL-related forcing code is ready to be shared with nuopc cap * Start updating forcings in nuopc cap Passing ice_frac, u10_sqr, and seaice_dust_flux; need another round of updates to handle the atm_dust_flux (split coarse / fine plus wet / dry) and the black carbon fluxes (split between hydrophilic and hydrophobic) * Add several new diagnostics for tracers Besides cleaning up some formatting, this commit adds {tracer}_zint, {tracer}_zint_100m, and {tracer}_SURF diagnostics. For MARBL tracers, it also adds Jint_{tracer} and Jint_100m_{tracer} (where J is the source / sink term returned by MARBL) Also renames marbl_forcing_type_main.F90 -> marbl_forcing_type_mod.F90 since I ended up not needing _main / _aux designations. * Register and post FLUX_CPL diagnostics Coupler recieves five fluxes used to compute dust_flux and iron_flux for MARBL (atm fine dust, atm coarse dust, atm black carbon, sea ice dust, and sea ice black carbon). These five fields are now available in history files. * First pass at adding support for river fluxes * Fix to read_attribute_str() If present(found), then return found=.false. instead of aborting if the attribute isn't defined (needed for DEPTH:edges from my initial condition file) * Code clean-up: Continued lines that previously extended beyond 132 characters * Update doxygen documentation * One more round of formatting clean-up gfortran imposes line limit of 132 characters, but a script in .testing/ checks for lines longer than 120... * Proper units for _zint and _zint_100m These diagnostics need to be computed with a length scale in m, since we are integrating over the column, but I had defined the diagnostic with the H_to_m conversion. Also, I need to use H_to_m instead of H_to_z (or H_to_RZ) * More river flux clean-up Introduced Time_riv_flux to force reading the file at the first times step. Also switched to a newer version of the file, which is already in mmol / m^2 / s (so no need to convert from nmol / cm^2 / s). * Add more fluxes to nuopc cap For additive fluxes, e.g. atm_bc_flux = bcphidry + bcphodry, this commit introduces a temporary array named marbl_work and computes the flux in multiple steps: 1. atm_bc_flux = 0 2. import bcphidry -> marbl_work 3. atm_bc_flux += marbl_work 4. import bcphodry -> marbl_work 5. atm_bc_flux += marbl_work as it turns out, state_getimport() is cummulative so this could be accomplished with 1. atm_bc_flux = 0 2. import bcphidry -> atm_bc_flux 3. import bcphodry -> atm_bc_flux That's coming in the next commit * Remove marbl_work from mom_cap_methods Since state_getimport() is cummulative, we call it repeated for the forcing fields that are the sum of multiple coupler fields * Refactor interacting with time_interp_external Introduce tracer_forcing_utils_mod to handle common interactions with time_interp_external (tracking offset if model / data time axes are different, setting an earliest / latest time to read from the file, etc) and then modify marbl_forcing_type_mod to use this new code for the river fluxes. * Fix formatting to make doxygen happy A few lines exceeded the character limit imposed by the "Doxygen and Style" continuous integration test * Pass bot_flux_to_tend to MARBL currently still using the KMT kludge, so this passes 1/dz in the bottom-most non-vanishing layer. Next step will be to remove kmt from the driver and use tracer_vertdiff to compute unit flux. * Use bot_flux_to_tend from tracer_vertdiff This commit still uses the KMT kludge, but now computes bot_flux_to_tend(:) by applying a unit bottom flux to a column of 0s in tracer_vertdiff. This commit includes a check to ensure that sum(dz(:) * bot_flux_to_tend(:)) == 1, though I am not sure if we want that in the code base long-term. This commit also fixes the units of the sfc_flux argument passed to tracer_vertdiff() -- it should be Rho0 * STF instead of just STF. This requires an update to MOM_tracer_diabatic (merged to dev/NCAR in 276954f but not yet on this branch); for testing, I copied the updated version of that file but am not committing it to make the future merge easier. Last note: I believe the btm_flux argument to tracer_vertdiff is actually positive upward, although the comments in MOM_tracer_diabatic.F90 claim it is negative upward. I'll investigate a little more and open an issue ticket with GFDL if that turns out to be the case, but in this commit I'm multiplying bot_flux_to_tend(:) by -m_per_cm instead of just m_per_cm and I suspect it's due to the sign of btm_flux * Remove KMT kludge Note that this required increasing max_bracket_grow_it (I used 5 instead of 3, but perhaps 4 would have been sufficient?) * Add bot_flux_to_tend to diagnostic output Also moved the conservation check (sum(dz * bot_flux_to_tend) == 1) into MARBL * Avoid allocating MARBL memory unless needed Functions in marbl_forcing_type_mod.F90 return immediately unless USE_MARBL_TRACERS=True. I also cleaned up the way that module knows what directory contains netCDF files to match how it is set up in MARBL_tracers.F90 (and make it easier to switch to DIN_LOC_ROOT when the time comes). * Add bot_flux_to_tend to dummy interface Building without pkg/MARBL was failing because the dummy interface was out of date * Split long line that doxygen flagged * Add BOT_FLUX_MIX_THICKNESS parameter Rather than relying on tracer_vertdiff, compute bot_flux_to_tend such that, for a parameter BOT_FLUX_MIX_THICKNESS, bot_flux_to_tend = 1/BOT_FLUX_MIX_THICKNESS for cells entirely contained that close to the ocean floor and then a weighted value for the cell that is partially within the bottom boundary layer (0 elsewhere). Relying on tracer_vertdiff led to convergence issues in the CO2 solver which have not cropped up under this implementation * Reformulate bot_flux_to_tend algorithm The previous algorithm had a (bathyT - zw(k)) term in it, and if these values are close together then we can lose precision in the resulting difference. However, this term can also be represented as the cummulative sum of dz(:) from the bottom to layer k and that formulation is much more accurate * Set default thickness for bot_flux_to_tend to 1m * Set tracer_inds outside of (.not. restart) block This is the first pass at a code cleanup; these indices should be set in register_MARBL_tracers(), not initialize_MARBL_tracers(). The next commit will further refactor this code. * Clean up how / where tracer_inds are set There was a bug in the code where CS%tracer_inds would not be set during a restart. Fixing the bug included a little more clean-up: 1. tracer_inds are set in a new routine rather than inline in initialize_MARBL_tracers() 2. This new routine is called from register_MARBL_tracers() 3. It should be possible to turn on BGC tracers in a branch / restart now * Clean up some comments * Check ref_depth for 2D diagnostics from MARBL If ref_depth is below the bottom of the column, MOM should use _FillValue rather than whatever value is reported from MARBL * Initialize negative tracer concentrations to 0 If the model is not initializing from a restart file, then we treat all negative tracer ICs as 0. I also swapped a couple of i- and j- loops to run through contiguous memory * Fix bugs in iron_flux computation Two major issues: 1. iron_flux was missing a few terms 2. I was keeping the units as kg / m^2 / s when MARBL wanted nmol / cm^2 / s I also switched the default riv_nut file to one interpolated from JRA * Need marbl_constants_mod.F90 for non-MARBL builds I added a reference to molw_Fe in marbl_forcing.F90, so I needed to update the dummy driver in config_src/externals/MARBL to recognize that use statement * Update doxygen documentation Forgot to document molw_Fe in the dummy marbl_constants module * Clean up how we read FESEDFLUX files 1. Default files now have DEPTH_EDGES variable so dz can be length ke 2. Improve logic for moving flux from below the ocean floor to bottom column 3. use v_extensive=.true. when registering FESEDFLUX diagnostic Also cleaned up how conversion factors are applied to dust / iron flux * Don't modify values read from restart! I had the logic to set negative tracer values to 0 in the wrong place; now it only applies to tracers read from initial conditions instead of also applying to tracers read from restart * Fix bug in accumulating 2D fields at ref_depth Use post_data(mask) instead of accumulating missing_val - this avoids inadvertently introducing round-off error when taking the average of an array full of missing_val (which would then not be missing_val any more) * Only allocate memory we plan to use Don't need to allocate memory in the diagnostic type for diagnostics that MOM6 is not including in any history files * Include (i,j) indices in MARBL errors When a specific column in MARBL returns an error, MARBL will now print both the global lat,lon (which it printed previously) and the global (i,j) indices * NUOPC cap improvements Fields that were posted from the cap (MARBL forcing fields) were not appearing correctly in the netCDF output because we needed to enable averaging * Bugfix in NUOPC cap I was using (i,j) indices instead of (i-i0,j-j0) when pulling data from MARBL_IOB * Fix formatting A couple of lines failed the line-length check in the CI * Add KPP Nonlocal Terms to MARBL tracers This commit mimics the changes made to MOM_CFC_cap.F90 and pseudo_salt_tracer.F90 to apply KPP Nonlocal terms to that MARBL tracers * Convert dust_flux to cgs before sending to MARBL * Move riv_flux to applyTracerBoundaryFluxesInOut Rather than adding river fluxes to CS%STF, created new array CS%RIV_FLUX that is used as in_flux_optional argument to applying boundary fluxes Also added a missing doxygen comment * Major refactor of MARBL forcing fields Removed marbl_forcing_type and marbl_ice_ocean_boundary_type, keeping the flat structure of forcing and ice_ocean_boundary_type, respectively. This greatly reduces the amount of code in marbl_forcing_type_mod.F90 (which now needs a new name), and adds a little more overhead to the driver layer but with the benefit of reusing pointers for things like ice_fraction and u10_sqr which are needed in the CFC cap as well. I also started the process of adding multiple ice category support, but there's more to do for that feature. * REVERT MCT CAP From this point forward, MCT will not support the MARBL driver. CESM users must use NUOPC cap for runs with MARBL * Rename marbl_forcing_type_mod.F90 There is no longer a forcing type, but this module does handle some forcing fields for MARBL so marbl_forcing_mod.F90 is a more appropriate name. * NUOPC cap set to receive all ice cat fields If CPL_I2O_PER_CAT=TRUE, then the nuopc cap allocates memory in ice_ocean_boundary_type to store the five fields that POP uses with MCOG: * sf_afrac * sf_afracr * Foxx_swnet_afracr * Fioi_swpen_ifrac_n * Si_ifrac_n Next step will be to work from the forcing_type side, and make sure those fields get copied into the appropriate arrays if the user requests running with multiple ice categories. * More per-category forcing updates 1. ice_ncat is stored as-is, rather than storing ice_ncat+1 2. Memory is now allocated on the forcing type if USE_ICE_CATEGORIES is true (Default is false, want default to be true when running with MARBL) * More ice category cleanup MARBL_tracers will get ICE_NCAT from parameters file (still need to set default correctly!) instead of passing it down the calling tree. * More ice category bug fixes 1. several off-by-one errors due to using ice_ncat+1 instead of ice_ncat 2. needed i0 and j0 when copying from IOB to fluxes 3. NUOPC is case sensitive when getting field, but doesn't abort when case is wrong Also added the fields passed to MARBL as MOM6 diagnostics (FRACR_CAT_N and QSW_CAT_N, for N from 1 to ice_ncat+1) -- should probably switch range so it is 0 to ice_ncat, with category 0 representing open ocean * don't post diagnostics if not requested when the _CAT_ diags were not in the diag_table, the run was aborting. Adding a check to make sure the id > 0 avoids that. * Remove kludgy threshold Before tracking down issue with i0 and j0, I had set an artificial threshold on fracr_cat, where I was treating values below 1e-5 as 0. This commit undoes that, and only treats negative values as 0 (leaving small positive values alone) * Rudimentary MARBL support in solo_driver All the MARBL-specific forcings the NUOPC cap gets from the mediator are set to 0: * ice_fraction * u10_sqr * dust_flux * iron_flux Will need to work out details on how else to populate these fields (ice_fraction is set to 0 when allocated, so that's probably okay) * Change dust / iron parameter defaults Fortran defaults are now what we want for C / G compsets, and MOM_interface will override them for B compsets * atm_press = 1 atm when p_surf_full is unavailable A kludge to set surface pressure to 1 atm when using solo_driver (which allocates memory for p_surf but not p_surf_full and then does not set p_surf) * Update IC file and units of RIV_FLUXES The old MARBL initial condition file had some issues at depth when the MOM topography was deeper than POP; these cells were all set to 0 because the restart file we mapped tracers from does not include a land mask. Fix was to mask out the POP data prior to mapping it, then the lateral fill was applied correctly. Additionally, Keith noticed a bug in our call to applyTracerBoundaryFluxesInOut() -- the in_flux_optional argument should be in units of conc m, but we were passing CS%RIV_FLUXES with units of conc m/s. Since the in_flux should be the time-integrated value, we set CS%RIV_FLUXES = CS%RIV_FLUXES * dt prior to passing it to applyTracerBoundaryFluxesInOut() The comments in the declaration of RIV_FLUXES was also updated to account for the unit change. * update fesedflux files Somewhere in transition from testing in cesm2_3_alpha05b to testing in cesm2_3_beta08, I forgot to commit a change to update the iron sediment flux forcing files. The previous files were generated in a buggy manner, and these new files provide better forcing. * Use data_override for some MARBL forcing ice fraction, u10_sqr, and the various dust / black carbon fluxes that MOM and POP receive from the CESM coupler in the NUOPC cap can now be read in from netCDF file using data_override in solo_driver/ also, added a flag (READ_RIV_FLUXES, default: .true.) to let us turn off looking for river flux files. * Support CHL_FROM_FILE=FALSE when using with MARBL If CHL_FROM_FILE is FALSE, then MARBL_tracers will request total_Chl from MARBL and MOM_tracer_flow_control::get_chl_from_model() can retrieve it. * Expand dummy cap for MARBL The previous commit used more of the MARBL interface, so I expanded the dummy cap to allow MOM6 to build without the full library (as before, setting USE_MARBL_TRACERS=TRUE but building the dummy cap will result in a FATAL error) * Refactor to use MARBL's get_output_for_GCM() Removed code that relied on interior_tendency_output since that no longer exists in MARBL * API for MARBL's get_output_for_GCM() changed Updated MARBL_tracers_get_output_for_GCM() to account for fact that MARBL doesn't want tracers passed in as an argument, it just wants to use self%tracers(). Also did some minor clean-up to MARBL_tracers_get_output_for_GCM(): 1. pass in G and GV so that we can index arrays properly / loop through i,j (and skip land cells) 2. the do j= and do i= loops are on the same line 3. abort if the MARBL function returns an error Lastly, cleaned up the interface to hopefully pass CI again (needed to create marbl_settings_mod and add dummy get_output_for_GCM() function to interface) * Use MOM_initialize_tracer_from_Z not tracer_Z_init I added an optional argument ongrid to MOM_initialize_tracer_from_Z() which gets passed through to horiz_interp_and_extrap_tracer() * More updates for reading IC file Switched CESM default to use IC file written on 1x1 grid (with WOA depths) instead of using a file on the tx0.66v1 grid. Also changed some of the defaults set in get_param() calls in MOM_initialize_tracer_from_Z() to match the defaults elsewhere in the code. * Update dummy interface for get_output_from_GCM() In MARBL, this changed from a function to a subroutine but I forgot to make the corresponding change in the dummy MARBL cap * Get NDEP from NUOPC instead of reading from file * Update solo_driver to handle ndep Last commit broke solo_driver because the API to convert_marbl_IOB_to_forcings() changed. Also, cleaned up some comments in MARBL_tracers.F90 and the NUOPC cap. * Remove NDEP_SCALE_FACTOR from parameters file I think this was a parameter because I was mimicking shr_stream (which includes a scale factor as part of the namelist options), but it makes far more sense to combine it with the existing ndep_conversion variable. Given the way the parentheses were used, this should be bit-for-bit. * Add MARBL_TRACERS_INIT_VERTICAL_REMAP_ONLY option If the initial condition file for the MARBL tracers is already on the MOM grid, this will skip the horizontal interpolation step. This option is not necessary for CESM-MOM6 (we want to interpolate ICs from the WOA grid), but is useful for MOM6-examples, where we are interpolating to a single column grid offline. * Update MARBL tracer IC file This one has been updated to set negative values -> 0 and then was run through the autotroph consistency check (if any of Chl, C, P, Fe, or Si are 0 they should all be 0) * Move atm_co2 and atm_alt_co2 to MOM_forcing_type This commit also moves ATM_CO2_CONST and ATM_ALT_CO2_CONST to marbl_forcing_mod and uses those values for the new forcing fields as preparation for possibly getting Sa_co2diag and Sa_co2prog from the mediator. Unrelated, I changed a handful of instances of "else if" to "elseif" to match what is done elsewhere in the code (these are all elseif statements I introduced on this branch earlier in development) * NUOPC cap can receive CO2 if provided MOM6 advertises for it, but if it is not available then it gets removed from importState and memory is deallocated so there is no attempt to get it (i.e. there is no error condition if the atmosphere does not provide it) * Support using coupler-provided atm_co2 Added ATM_CO2_OPT and ATM_ALT_CO2_OPT, which default to "const" but also support "prognostic" or "diagnostic" if the coupler is providing those fields. Also renamed marbl_forcing_mod -> MARBL_forcing_mod to be consistent with capitalization in MARBL_tracers.F90 * Replace logical flags with integer For ATM_CO2_OPT and ATM_ALT_CO2_OPT, we do a string -> integer conversion instead of trying to track all possible options via logicals. This introduces some new module-level parameters in MARBL_forcing_mod.F90 (and I noticed a formatting issue in MARBL_tracers.F90 when checking how other modules handle parameters) * NUOPC cap can pass CO2_FLUX to atmosphere Added Faoo_fco2_ocn to the exportState and modified sfc_state to be able to pass ocn_co2 to ocean_public, which then gets exported in mom_cap_methods:mom_export() In src/tracer/, I needed to set up MARBL's surface_flux_output and use it to request co2_flux. MOM_tracer_flow_control now calls MARBL_tracers_surface_state(), which copies the flux from MARBL's control structure to sfc_state. I also did a bit of code cleanup, deallocating more arrays in the MARBL control structure prior to deallocating CS itself. * Only copy co2 to srf_state if memory was allocated solo_driver doesn't allocate memory in sfc_state to pass CO2 flux back to the atmosphere and was seg-faulting without the if (allocated) check * Code clean-up following review 1. sfc_state%sfc_co2 -> sfc_state%fco2 2. re-order some if states and do loops (want if statements outside do loops as much as possible) * Remove spaces in "end if" and "end do" The MOM6 style guide explicitly states we should use endif and enddo with no space * More code clean-up 1. solo_driver has callTree_leave() call in MARBL forcing override routine 2. allocate() statements use the source= argument as much as possible 3. cleaned up spacing in if statements [a mix of "if(condition) then" and "if (condition)then" 4. removed unnecessary use statement in mom_cap_methods, and cleaned up vague comment 5. renamed ocean_public%ocn_co2 -> ocean_public%fco2_ocn * Clean up NUOPC cap Move more calls into if (cesm_coupled) blocks because they require CESM forcings from CMEPS * Updates to use support_mks branch of MARBL This branch of MARBL requires the unit_system argument in a few places; sticking with cgs introduces a few round-off level differences due to restructing some internal MARBL computations. * Update dummy driver to add unit_system args Because the API to MARBL changed, I needed to update some code in config_src/externals/MARBL * Use MARBL in mks, not cgs Requires the support_mks branch of MARBL as well as generating marbl_in with --unit_system mks * Update default for iron forcing files MARBL_FESEDFLUX_FILE and MARBL_FEVENTFLUX_FILE were updated to remove the incorrect 1D horizontal dimensions (and rename the dimensions nx and ny so that categorize_axes could still figure out how to read the files) * Updated pkg/MARBL, which changed API A couple arguments changed in functions called from MARBL_tracers.F90 and I caught a mistake in the comments of MARBL_forcing_mod.F90. Also updated the dummy API so the model continues to build when MARBL is not available. * Dummy MARBL API needs one more function The MARBL driver calls marbl_instances%get_conc_flux_units(), which I had forgotten to add to the dummy cap * MARBL API changed replaced surface_flux_output%add_output with add_output_from_GCM(); this commit uses the new API from MARBL and also updates the dummy API so we can still build without MARBL * Don't need to overwrite tracer_restore_vars A MARBL update (reflected in MOM_interface) puts empty strings in tracer_restore_vars by default for MOM6, so we don't need to remove the POP defaults in the Fortran code anymore * Use time_interp_external for restoring This is still a work in progress, but I cleaned up how the MARBL tracer restoring fields are translated into something the MARBL_tracers control structure can parse and also call init_external_field. One issue I'm having is that time_interp_external needs a time_type argument, and that's not available in MARBL_tracers_column_physics. I think the solution will be to move a lot of this code to MARBL_forcing.F90, but I want to do that in a separate commit. * First pass at implementing tracer restoring Uses time_interp_external to temporally interpolate restoring fields; assumes data is on correct spatial grid, and then does vertical interpolation to go from data's vertical grid to current MOM6 grid (similar to iron sediment flux). Still to do: vertical interpolation of restoring time scale * Clean-up to avoid truncation errors Was failing some CI tests due to truncation issues * Switch from interpolate_column to remapping_core_h interpolate_column() is meant for interpolating from cell interfaces, not cell centers. MOM_initialize_tracer_from_Z() uses ALE_remap_scalar(), which just calls remapping_core_h() under the hood, so that's what we want to use for vertical interpolation of the restoring fields and time scales. * enable_averaging -> enable_averages previous merge contained a change to this function name, so my MARBL code additions were stuck calling the wrong one * Move river flux code into MARBL_tracers 1. MARBL_forcing_mod should just be for fields that pass through the MOM6 cap 2. River fluxes shouldn't be in the forcing datatype 3. MARBL_tracers_set_forcing() is already set up to handle fields read in with time_interp_external * move post_data calls for river nutrient fluxes Diags are posted after files are read in set_forcing(). Also, cleaned up where I apply the dt factor to convert from flux to time-integrated flux because set_forcing is only called once during the first two time steps so we were inadvertently applying a factor of dt^2 on the second time step. This commit is bit-for-bit with 69202f7 in my CESM testing, which wasn't the case for 5540525 * Code cleanup: doxygen test Several "Line length exceeded" messages in CI, addressed by adding continuation lines instead * More doxygen clean-up * Missing "<" in one comment Had a ! instead of !< when documenting a variable in a class * First pass at adding ABIO Still need to update d14c forcing, currently hardcoded to use -4 (we want to read from a file with dimensions time,lat_band and interpolate in time) * Add MARBL_TRACERS_MAY_REINIT to param file The default is still false, but in some cases (branching off a run that did not have MARBL enabled) it would be useful to set as true instead * Add dummy get_setting() to marbl_interface_class Now that I call get_setting() to determine which MARBL tracer modules are enabled, the dummy cap also needs this function * Skip some processes when not base_bio_on If base_bio_on is false, we don't want to request any output from the GCM or deal with the iron flux forcing fields * Add support for reading d14c forcing from netcdf Use time_interp_external to read in d14c in three latitude bands; in putting this together, I also found a bug in tracer_forcing_utils that resulted in being off by a year when reading constant forcing (river fluxes were interpolated to Jan 1, 1901, rather than Jan 1, 1900; fixing it also meant updating the forcing file so there was data to read on Jan 1, 1900, since the original dataset begins on July 1 of that year). Also, following the GFDL MOM6 call, I added parentheses around the square term in "a * b**2" constructs [this was a bit-for-bit change on derecho, but some machines treat "a * b**2" as "(a*b)*b" instead of "a*(b*b)"] * Update to support marbl0.46.0 That tag changed how total 3d chlorophyll is passed from MARBL to the GCM * Update interface to build without MARBL marbl0.46.0 updated the MARBL interface, so that needs to be reflected in the config_src/ version * Shorten line that exceeded max length doxygen test was failing because I added some whitespace between variable declaration and inline comment; I broke the comment over two lines to fix * Fix whitespace MARBL_tracers.F90 and MARBL_forcing_mod.F90 now comply with whitespace rules from the MOM6 style guide * Check abio_dic_on and base_bio_on before posting There are a few diagnostics that are only defined if base_bio_on=.true. (the river flux nutrient forcing fields), and one that is only defined if abio_dic_on=.true. (the d14c forcing); some compilers won't initialize the diagnostic ids to 0 in the control structure, so we need to either explicitly initialize all the ids or only call post_data when we know the ids have been set. This commit does the latter. * Updates for dimensional scaling test Currently fails T-scaling test with solo driver, probably fails lots of other scaling tests as well. This commit 1. Adds debug output to MARBL_tracers.F90 2. Gets dimensions correct in comments of MOM_forcing_type, MARBL_forcing_mod, and MARBL_tracers 3. Scales forcings correctly for the MARBL surface_flux_compute() step (at least in T); output highlights issues in computing source / sink term from interior_tendency_compute() One of the biggest changes from this commit is the handling of units for the nitrogen deposition fluxes. It looks like they were coming in as kg/m^2/s, being converted to mol/L^2/T in fluxes%{nhx_dep,noy_dep}, and then converted to mmol/m^2/s when copied into MARBL. Now the intermediate stage is mmol/m^3 Z/T; this is not bit-for-bit with the previous setup because I went from multiplying by (1000/14) (kg -> mol) and then another 1000 in the third step (mol -> mmol) to just multiplying by 1e6/14 (kg -> mmol) in the second step. * More dimensional scaling updates With solo_driver, the following runs are all bit-for-bit with non-scaled runs: C_RESCALE_POWER = 10 H_RESCALE_POWER = 10 L_RESCALE_POWER = 10 S_RESCALE_POWER = 10 T_RESCALE_POWER = 10 Z_RESCALE_POWER = 10 * Clean up line-lengths in some comments Should pass doxygen test again * pass phys units to convert_marbl_IOB_to_forcings() The function is meant to help copy fields from the ice_ocean_boundary_type (which is in physical units in all the caps) to the forcing_type (which wants scaled units). So the solo_driver should NOT scale the dust, black carbon, or NDEP inputs from data_override, and instead that scaling should happen in MARBL_forcing_mod.F90 * scale riv flux applyTracerBoundaryFluxesInOut expects in_flux_optional in units of conc H, and we were passing conc m T/s. Since riv_flux_loc is now conc H, I also added a debug-gated hchksum on it. * Introduce MARBL_IC_MIN_VAL for testing The dimensional scaling tests fail if the MARBL tracer concentrations are very very small (O(1e-300)); this can be avoided by setting the minimum tracer value to be 1e-100 instead of 0. We don't want to do this for production runs, though, so the default for this parameter is still 0. * Fixed a few area correction bugs Sa_co2prog and Sa_co2diag should not be area corrected (they are states) but Faoo_fco2_ocn should be (it's a flux) * No support for global ops yet When calling marbl_instance%init(), we should tell MARBL that MOM6 doesn't have the global operators that MARBL expects (global sums / running means) so we get the appropriate error message when trying to run with ladjust_bury_coeff = True * Add chksum calls for MARBL forcings Updated ice_ocn_bnd_type_chksum() in the NUOPC cap, though I don't think this function is ever called * MARBL input data is now in INPUTDATA I had created CESM_INPUTDATA as a parameter to point to my work directory, but it is no longer necessary because INPUTDATA points to the CESM input data repository and I've moved necessary files there * Changes following code review -- cleaned up a lot of comments and whitespace -- used source argument in more allocate statements, and deallocated more arrays -- 3D diags now have zl:mean in cell_methods attribute -- marbl_instances%domain%kmt is set once (during initialization) * Call MARBL_tracers_stock() * Only use MARBL for Chl when using base_bio tracers If MARBL is not configured to provide the base biotic tracers, then it will not be able to provide chlorophyll. In that case, if CHL_FROM_FILE=False, MOM6 needs to get chlorophyll from the generic tracers. * tracer_forcing_utils moved into MOM_interpolate To make these subroutines more accessible, they were moved out of src/tracer/ and made available through MOM_interpolate * Fix whitespace in comments * Add some variable descriptions If variable was described in POP comment, I copied the comment over. Otherwise I came up with a description on my own. * Use do loops instead of ':' time_interp_external() does not update halo regions, so running CESM with DEBUG=TRUE was triggering some overflows from uninitialized memory. Intead of copying the entire array, we now loop through (is:ie,js:je) when accessing an array returned from time_interp_external() * Add parameter to change restoring time scale name Most use cases don't include restoring for MARBL tracers, but when that feature is enabled and the time scale is read from a file the user can specify what variable to read from the netCDF file (default is I_TAU to match naming convention in MOM6, but some test cases are based on POP files and will need to read RTAU) --- .gitignore | 9 + config_src/drivers/nuopc_cap/mom_cap.F90 | 254 +- .../drivers/nuopc_cap/mom_cap_methods.F90 | 242 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 68 +- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 96 +- config_src/drivers/nuopc_cap/time_utils.F90 | 4 +- .../solo_driver/MOM_surface_forcing.F90 | 106 +- config_src/external/MARBL/README.md | 6 + .../external/MARBL/marbl_constants_mod.F90 | 11 + config_src/external/MARBL/marbl_interface.F90 | 134 + .../MARBL/marbl_interface_public_types.F90 | 89 + config_src/external/MARBL/marbl_logging.F90 | 38 + pkg/CVMix-src | 2 +- src/core/MOM_forcing_type.F90 | 77 +- src/core/MOM_variables.F90 | 14 +- src/framework/MOM_interpolate.F90 | 77 +- .../MOM_tracer_initialization_from_Z.F90 | 12 +- src/parameterizations/MARBL | 1 + src/tracer/MARBL_forcing_mod.F90 | 378 +++ src/tracer/MARBL_tracers.F90 | 2206 +++++++++++++++++ src/tracer/MOM_hor_bnd_diffusion.F90 | 2 +- src/tracer/MOM_tracer_Z_init.F90 | 2 +- src/tracer/MOM_tracer_flow_control.F90 | 44 +- src/tracer/MOM_tracer_registry.F90 | 68 +- src/tracer/MOM_tracer_types.F90 | 1 + 25 files changed, 3772 insertions(+), 169 deletions(-) create mode 100644 config_src/external/MARBL/README.md create mode 100644 config_src/external/MARBL/marbl_constants_mod.F90 create mode 100644 config_src/external/MARBL/marbl_interface.F90 create mode 100644 config_src/external/MARBL/marbl_interface_public_types.F90 create mode 100644 config_src/external/MARBL/marbl_logging.F90 create mode 120000 src/parameterizations/MARBL create mode 100644 src/tracer/MARBL_forcing_mod.F90 create mode 100644 src/tracer/MARBL_tracers.F90 diff --git a/.gitignore b/.gitignore index 25f7524d1c..c57b950fc2 100644 --- a/.gitignore +++ b/.gitignore @@ -4,6 +4,15 @@ html +# Build output +*.o +*.mod +MOM6 +build/ +deps/ +pkg/MARBL + + # Autoconf output aclocal.m4 autom4te.cache/ diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 3574943918..83eddf7265 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -293,7 +293,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then read(value,*) dbug - end if + endif write(logmsg,'(i6)') dbug call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -370,7 +370,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) use_mommesh call ESMF_LogWrite('MOM_cap:use_mommesh = '//trim(logmsg), ESMF_LOGMSG_INFO) - if(use_mommesh)then + if (use_mommesh) then geomtype = ESMF_GEOMTYPE_MESH call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) if (.not. isPresent .and. .not. isSet) then @@ -443,6 +443,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) character(len=32) :: calendar character(len=:), allocatable :: rpointer_filename integer :: inst_index + logical :: i2o_per_cat real(8) :: MPI_Wtime, timeiads !-------------------------------- @@ -560,6 +561,34 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) + !----------------- + ! optional input from cice columns due to ice thickness categories + !----------------- + + Ice_ocean_boundary%ice_ncat = 0 + if (cesm_coupled) then + ! Note that flds_i2o_per_cat is set by the env_run.xml variable CPL_I2O_PER_CAT + ! This xml variable is set by MOM_interface's buildnml script; it has the same + ! value as USE_MARBL in the case + call NUOPC_CompAttributeGet(gcomp, name='flds_i2o_per_cat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) i2o_per_cat + if (is_root_pe()) then + write(stdout,*) 'i2o_per_cat = ',i2o_per_cat + endif + + ! Note that ice_ncat is set by the env_run.xml variable ICE_NCAT which is set + ! by the ice component (default is 1) + if (i2o_per_cat) then + call NUOPC_CompAttributeGet(gcomp, name='ice_ncat', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + read(cvalue,*) Ice_ocean_boundary%ice_ncat + endif + if (is_root_pe()) then + write(stdout,*) 'ice_ncat = ', Ice_ocean_boundary%ice_ncat + endif + end if + if (is_root_pe()) then write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif @@ -663,74 +692,70 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) - allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & - Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & - Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & - Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& - Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & - Ice_ocean_boundary% mi (isc:iec,jsc:jec), & - Ice_ocean_boundary% ice_fraction (isc:iec,jsc:jec), & - Ice_ocean_boundary% u10_sqr (isc:iec,jsc:jec), & - Ice_ocean_boundary% p (isc:iec,jsc:jec), & - Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & - Ice_ocean_boundary% frunoff (isc:iec,jsc:jec)) - - Ice_ocean_boundary%u_flux = 0.0 - Ice_ocean_boundary%v_flux = 0.0 - Ice_ocean_boundary%t_flux = 0.0 - Ice_ocean_boundary%q_flux = 0.0 - Ice_ocean_boundary%salt_flux = 0.0 - Ice_ocean_boundary%lw_flux = 0.0 - Ice_ocean_boundary%sw_flux_vis_dir = 0.0 - Ice_ocean_boundary%sw_flux_vis_dif = 0.0 - Ice_ocean_boundary%sw_flux_nir_dir = 0.0 - Ice_ocean_boundary%sw_flux_nir_dif = 0.0 - Ice_ocean_boundary%lprec = 0.0 - Ice_ocean_boundary%fprec = 0.0 - Ice_ocean_boundary%seaice_melt = 0.0 - Ice_ocean_boundary%seaice_melt_heat= 0.0 - Ice_ocean_boundary%mi = 0.0 - Ice_ocean_boundary%ice_fraction = 0.0 - Ice_ocean_boundary%u10_sqr = 0.0 - Ice_ocean_boundary%p = 0.0 - Ice_ocean_boundary%lrunoff = 0.0 - Ice_ocean_boundary%frunoff = 0.0 + allocate(Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% t_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% q_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% salt_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% lw_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_vis_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dir (isc:iec,jsc:jec), & + Ice_ocean_boundary% sw_flux_nir_dif (isc:iec,jsc:jec), & + Ice_ocean_boundary% lprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% fprec (isc:iec,jsc:jec), & + Ice_ocean_boundary% seaice_melt_heat (isc:iec,jsc:jec),& + Ice_ocean_boundary% seaice_melt (isc:iec,jsc:jec), & + Ice_ocean_boundary% mi (isc:iec,jsc:jec), & + Ice_ocean_boundary% ice_fraction (isc:iec,jsc:jec), & + Ice_ocean_boundary% u10_sqr (isc:iec,jsc:jec), & + Ice_ocean_boundary% p (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff (isc:iec,jsc:jec), & + source=0.0) + + ! Allocate memory for fields coming from multiple ice categories + if (Ice_ocean_boundary%ice_ncat > 0) & + allocate(Ice_ocean_boundary% afracr(isc:iec,jsc:jec), & + Ice_ocean_boundary% swnet_afracr(isc:iec,jsc:jec), & + Ice_ocean_boundary% swpen_ifrac_n(isc:iec,jsc:jec,1:Ice_ocean_boundary%ice_ncat), & + Ice_ocean_boundary% ifrac_n(isc:iec,jsc:jec,1:Ice_ocean_boundary%ice_ncat), & + source=0.0) if (cesm_coupled) then - allocate (Ice_ocean_boundary% hrain (isc:iec,jsc:jec), & - Ice_ocean_boundary% hsnow (isc:iec,jsc:jec), & - Ice_ocean_boundary% hrofl (isc:iec,jsc:jec), & - Ice_ocean_boundary% hrofi (isc:iec,jsc:jec), & - Ice_ocean_boundary% hevap (isc:iec,jsc:jec), & - Ice_ocean_boundary% hcond (isc:iec,jsc:jec)) - - Ice_ocean_boundary%hrain = 0.0 - Ice_ocean_boundary%hsnow = 0.0 - Ice_ocean_boundary%hrofl = 0.0 - Ice_ocean_boundary%hrofi = 0.0 - Ice_ocean_boundary%hevap = 0.0 - Ice_ocean_boundary%hcond = 0.0 + allocate(Ice_ocean_boundary% hrain (isc:iec,jsc:jec), & + Ice_ocean_boundary% hsnow (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofl (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofi (isc:iec,jsc:jec), & + Ice_ocean_boundary% hevap (isc:iec,jsc:jec), & + Ice_ocean_boundary% hcond (isc:iec,jsc:jec), & + source=0.0) + + ! Needed for MARBL + ! These are allocated separately to make it easier to pull out + ! of the cesm_coupled block if other models want to add BGC + allocate(Ice_ocean_boundary% nhx_dep (isc:iec,jsc:jec), & + Ice_ocean_boundary% noy_dep (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_fine_dust_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_coarse_dust_flux (isc:iec,jsc:jec),& + Ice_ocean_boundary% seaice_dust_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_bc_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% seaice_bc_flux (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_co2_prog (isc:iec,jsc:jec), & + Ice_ocean_boundary% atm_co2_diag (isc:iec,jsc:jec), & + source=0.0) endif call query_ocean_state(ocean_state, use_waves=use_waves, wave_method=wave_method) if (use_waves) then if (wave_method == "EFACTOR") then - allocate( Ice_ocean_boundary%lamult(isc:iec,jsc:jec) ) - Ice_ocean_boundary%lamult = 0.0 + allocate( Ice_ocean_boundary%lamult(isc:iec,jsc:jec), source=0.0) else if (wave_method == "SURFACE_BANDS") then call query_ocean_state(ocean_state, NumWaveBands=Ice_ocean_boundary%num_stk_bands) - allocate(Ice_ocean_boundary%ustkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), source=0.0) - allocate(Ice_ocean_boundary%vstkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), source=0.0) - allocate(Ice_ocean_boundary%stk_wavenumbers(Ice_ocean_boundary%num_stk_bands), source=0.0) + allocate(Ice_ocean_boundary%ustkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%vstkb(isc:iec,jsc:jec,Ice_ocean_boundary%num_stk_bands), & + Ice_ocean_boundary%stk_wavenumbers(Ice_ocean_boundary%num_stk_bands), & + source=0.0) call query_ocean_state(ocean_state, WaveNumbers=Ice_ocean_boundary%stk_wavenumbers, unscale=.true.) else call MOM_error(FATAL, "Unsupported WAVE_METHOD encountered in NUOPC cap.") @@ -776,6 +801,32 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi" , "will provide") + if (Ice_ocean_boundary%ice_ncat > 0) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sf_afracr", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_afracr", "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_swpen_ifrac_n", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%ice_ncat) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac_n", "will provide", & + ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%ice_ncat) + endif + + if (cesm_coupled) then + ! Fields needed for MARBL + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_ndep" , "will provide", & !-> nitrogen deposition + ungridded_lbound=1, ungridded_ubound=2) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_dstwet" , "will provide", & + ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_dstdry" , "will provide", & + ungridded_lbound=1, ungridded_ubound=4) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_bcph" , "will provide", & + ungridded_lbound=1, ungridded_ubound=3) + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_flxdst" , "will provide") !-> ice runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_bcphi" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_bcpho" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_co2prog" , "will provide") !-> prognostic CO2 from atm + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_co2diag" , "will provide") !-> diagnostic CO2 from atm + endif + if (use_waves) then if (wave_method == "EFACTOR") then call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") @@ -799,6 +850,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdy" , "will provide") call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Fioo_q" , "will provide") call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") + if (cesm_coupled) then + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Faoo_fco2_ocn", "will provide") + endif do n = 1,fldsToOcn_num call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) @@ -1142,7 +1196,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh call MOM_error(FATAL, err_msg) - end if + endif diff_lat = abs(latMesh(n) - lat(n)) if (diff_lat > eps_omesh) then frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& @@ -1150,17 +1204,18 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh call MOM_error(FATAL, err_msg) - end if + endif if (abs(maskMesh(n) - mask(n)) > 0) then frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" write(err_msg, frmt)n,maskMesh(n),mask(n) call MOM_error(FATAL, err_msg) - end if + endif end do ! realize the import and export fields using the mesh - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", & + ice_ocean_boundary=Ice_ocean_boundary, mesh=Emesh, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) @@ -1176,10 +1231,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate (mod2med_areacor(numOwnedElements)) - allocate (med2mod_areacor(numOwnedElements)) - mod2med_areacor(:) = 1._ESMF_KIND_R8 - med2mod_areacor(:) = 1._ESMF_KIND_R8 + allocate(mod2med_areacor(numOwnedElements), & + med2mod_areacor(numOwnedElements), & + source=1._ESMF_KIND_R8) #ifdef CESMCOUPLED ! Determine model areas and flux correction factors (module variables in mom_) @@ -1201,7 +1255,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 mod2med_areacor(k) = model_areas(k) / mesh_areas(k) med2mod_areacor(k) = mesh_areas(k) / model_areas(k) - end if + endif end do end do deallocate(mesh_areas) @@ -1222,7 +1276,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) min_areacor_glob(1), max_areacor_glob(1), 'MOM6' write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& min_areacor_glob(2), max_areacor_glob(2), 'MOM6' - end if + endif #endif deallocate(ownedElemCoords) @@ -1409,7 +1463,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) - if(grid_attach_area) then + if (grid_attach_area) then dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) endif enddo @@ -1451,7 +1505,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) gridOut = gridIn ! for now out same as in - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", & + ice_ocean_boundary=Ice_ocean_boundary, grid=gridIn, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) @@ -1736,7 +1791,7 @@ subroutine ModelAdvance(gcomp, rc) if (dbug > 0) then call state_diagnose(importState,subname//':IS ',rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + endif !--------------- ! Get ocean grid @@ -1755,10 +1810,10 @@ subroutine ModelAdvance(gcomp, rc) ! Update MOM6 !--------------- - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") + if (profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled, & cesm_coupled) - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") + if (profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") !--------------- ! Export Data @@ -1770,7 +1825,7 @@ subroutine ModelAdvance(gcomp, rc) if (dbug > 0) then call state_diagnose(exportState,subname//':ES ',rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + endif endif !--------------- @@ -2025,7 +2080,7 @@ subroutine ModelSetRunClock(gcomp, rc) if (isPresent .and. isSet) then call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) read(cvalue,*) restart_n - if (restart_n /= 0)then + if (restart_n /= 0) then call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2068,7 +2123,7 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) - end if + endif ! create a 1-shot alarm at the driver stop time stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) @@ -2176,9 +2231,9 @@ subroutine ocean_model_finalize(gcomp, rc) write_restart = .true. else write_restart = .false. - end if - if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & - ESMF_LOGMSG_INFO) + endif + if (write_restart) call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & + ESMF_LOGMSG_INFO) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) @@ -2227,16 +2282,17 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ end subroutine State_SetScalar !> Realize the import and export fields using either a grid or a mesh. -subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) - type(ESMF_State) , intent(inout) :: state !< ESMF_State object for - !! import/export fields. - integer , intent(in) :: nfields !< Number of fields. - type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's - !! information. - character(len=*) , intent(in) :: tag !< Import or export. - type(ESMF_Grid) , intent(in), optional :: grid!< ESMF grid. - type(ESMF_Mesh) , intent(in), optional :: mesh!< ESMF mesh. - integer , intent(inout) :: rc !< Return code. +subroutine MOM_RealizeFields(state, nfields, field_defs, tag, ice_ocean_boundary, grid, mesh, rc) + type(ESMF_State) , intent(inout) :: state !< ESMF_State object for + !! import/export fields. + integer , intent(in) :: nfields !< Number of fields. + type(fld_list_type) , intent(inout) :: field_defs(:) !< Structure with field's + !! information. + type(ice_ocean_boundary_type), intent(inout), optional :: ice_ocean_boundary !< May need to nullify atm_co2 + character(len=*) , intent(in) :: tag !< Import or export. + type(ESMF_Grid) , intent(in) , optional :: grid!< ESMF grid. + type(ESMF_Mesh) , intent(in) , optional :: mesh!< ESMF mesh. + integer , intent(inout) :: rc !< Return code. ! local variables integer :: i @@ -2316,6 +2372,18 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is not connected.", & ESMF_LOGMSG_INFO) + if (present(ice_ocean_boundary)) then + if (trim(field_defs(i)%stdname) == 'Sa_co2prog') then + if (is_root_pe()) write(stdout,*) subname // tag // " Nullifying ice_ocean_boundary%atm_co2_prog" + deallocate(ice_ocean_boundary%atm_co2_prog) + nullify(ice_ocean_boundary%atm_co2_prog) + elseif (trim(field_defs(i)%stdname) == 'Sa_co2diag') then + if (is_root_pe()) write(stdout,*) subname // tag // " Nullifying ice_ocean_boundary%atm_co2_diag" + deallocate(ice_ocean_boundary%atm_co2_diag) + nullify(ice_ocean_boundary%atm_co2_diag) + endif + endif + ! remove a not connected Field from State call ESMF_StateRemove(state, (/field_defs(i)%shortname/), rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2390,7 +2458,7 @@ subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname, ungridd if (present(ungridded_lbound) .and. present(ungridded_ubound)) then fldlist(num)%ungridded_lbound = ungridded_lbound fldlist(num)%ungridded_ubound = ungridded_ubound - end if + endif end subroutine fld_list_add diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index 125bae5748..d5ec9dc259 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -42,6 +42,7 @@ module MOM_cap_methods !> Get field pointer interface State_GetFldPtr module procedure State_GetFldPtr_1d + module procedure State_GetFldPtr_1d_from_2d module procedure State_GetFldPtr_2d end interface @@ -82,12 +83,14 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! Local Variables integer :: i, j, ib, ig, jg, n integer :: isc, iec, jsc, jec + integer :: esmf_ind integer :: nsc ! number of stokes drift components character(len=128) :: fldname real(ESMF_KIND_R8), allocatable :: taux(:,:) real(ESMF_KIND_R8), allocatable :: tauy(:,:) real(ESMF_KIND_R8), allocatable :: stkx(:,:,:) real(ESMF_KIND_R8), allocatable :: stky(:,:,:) + logical :: med_has_co2 character(len=*) , parameter :: subname = '(mom_import)' rc = ESMF_SUCCESS @@ -271,6 +274,159 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, if (ChkErr(rc,__LINE__,u_FILE_u)) return endif + !--------------! + ! MARBL fields ! + !--------------! + + ! seaice_dust_flux, nhx_dep, and noy_dep are single fields from the coupler + ! atm_fine_dust_flux, atm_coarse_dust_flux, atm_bc_flux, and seaice_bc_flux + ! are all sums of multiple fields and will be treated slightly differently + ! For those fields, we use do_sum = .true. + + !---- + ! nhx deposition + !---- + if (associated(ice_ocean_boundary%nhx_dep)) then + call state_getimport(importState, 'Faxa_ndep', & + isc, iec, jsc, jec, ice_ocean_boundary%nhx_dep(:,:), & + areacor=med2mod_areacor, esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! noy deposition + !---- + if (associated(ice_ocean_boundary%noy_dep)) then + call state_getimport(importState, 'Faxa_ndep', & + isc, iec, jsc, jec, ice_ocean_boundary%noy_dep(:,:), & + areacor=med2mod_areacor, esmf_ind=2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! atmospheric CO2 concentration + ! might not be passed from atmosphere component, + ! in which the pointer(s) will not be associated + !---- + if (associated(ice_ocean_boundary%atm_co2_prog)) then + call state_getimport(importState, 'Sa_co2prog', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_co2_prog(:,:), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + if (associated(ice_ocean_boundary%atm_co2_diag)) then + call state_getimport(importState, 'Sa_co2diag', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_co2_diag(:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + endif + + !---- + ! fine dust flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_fine_dust_flux)) then + ice_ocean_boundary%atm_fine_dust_flux(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Faxa_dstwet', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_fine_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Faxa_dstdry', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_fine_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! coarse dust flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_coarse_dust_flux)) then + ice_ocean_boundary%atm_coarse_dust_flux(:,:) = 0._ESMF_KIND_R8 + do esmf_ind=2,4 + call state_getimport(importState, 'Faxa_dstwet', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_coarse_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Faxa_dstdry', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_coarse_dust_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + end if + + !---- + ! dust flux from sea ice + !---- + if (associated(ice_ocean_boundary%seaice_dust_flux)) then + call state_getimport(importState, 'Fioi_flxdst', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_dust_flux, & + areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + !---- + ! black carbon flux from atmosphere + !---- + if (associated(ice_ocean_boundary%atm_bc_flux)) then + ice_ocean_boundary%atm_bc_flux(:,:) = 0._ESMF_KIND_R8 + do esmf_ind=1,3 + call state_getimport(importState, 'Faxa_bcph', & + isc, iec, jsc, jec, ice_ocean_boundary%atm_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., esmf_ind=esmf_ind, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + enddo + endif + + !---- + ! black carbon flux from sea ice + !---- + if (associated(ice_ocean_boundary%seaice_bc_flux)) then + ice_ocean_boundary%seaice_bc_flux(:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Fioi_bcpho', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getimport(importState, 'Fioi_bcphi', & + isc, iec, jsc, jec, ice_ocean_boundary%seaice_bc_flux(:,:), & + areacor=med2mod_areacor, do_sum=.true., rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! Fields coming from coupler per ice category + if (ice_ocean_boundary%ice_ncat > 0) then + call state_getimport(importState, 'Sf_afracr', & + isc, iec, jsc, jec, ice_ocean_boundary%afracr(:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Foxx_swnet_afracr', & + isc, iec, jsc, jec, ice_ocean_boundary%swnet_afracr(:,:), & + areacor=med2mod_areacor, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Fioi_swpen_ifrac_n', & + isc, iec, jsc, jec, 1, ice_ocean_boundary%ice_ncat, & + ice_ocean_boundary%swpen_ifrac_n(:,:,:), & + areacor=med2mod_areacor, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + + call state_getimport(importState, 'Si_ifrac_n', & + isc, iec, jsc, jec, 1, ice_ocean_boundary%ice_ncat, & + ice_ocean_boundary%ifrac_n(:,:,:), rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & + line=__LINE__, & + file=__FILE__)) & + return ! bail out + endif ! multiple ice categories + !---- ! salt flux from ice !---- @@ -529,16 +685,13 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Sea-surface zonal and meridional slopes !---------------- - allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed)) ! local indices with halos - allocate(dhdx(isc:iec, jsc:jec)) !global indices without halos - allocate(dhdy(isc:iec, jsc:jec)) !global indices without halos + allocate(ssh(ocean_grid%isd:ocean_grid%ied,ocean_grid%jsd:ocean_grid%jed), & ! local indices with halos + dhdx(isc:iec, jsc:jec), & !global indices without halos + dhdy(isc:iec, jsc:jec), & !global indices without halos + source=0.0_ESMF_KIND_R8) allocate(dhdx_rot(isc:iec, jsc:jec)) !global indices without halos allocate(dhdy_rot(isc:iec, jsc:jec)) !global indices without halos - ssh = 0.0_ESMF_KIND_R8 - dhdx = 0.0_ESMF_KIND_R8 - dhdy = 0.0_ESMF_KIND_R8 - ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) do j = ocean_grid%jsc, ocean_grid%jec jloc = j + ocean_grid%jdg_offset @@ -629,6 +782,16 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, call State_SetExport(exportState, 'So_dhdy', isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! ------- + ! CO2 Flux + ! ------- + call ESMF_StateGet(exportState, 'Faoo_fco2_ocn', itemFlag, rc=rc) + if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then + call State_SetExport(exportState, 'Faoo_fco2_ocn', isc, iec, jsc, jec, & + ocean_public%fco2_ocn, ocean_grid, areacor=mod2med_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) end subroutine mom_export @@ -654,6 +817,32 @@ subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) end subroutine State_GetFldPtr_1d +!> Get specific 1D field pointer from 2D field +subroutine State_GetFldPtr_1d_from_2d(State, fldname, esmf_ind, fldptr, rc) + type(ESMF_State) , intent(in) :: State !< ESMF state + character(len=*) , intent(in) :: fldname !< Field name + real(ESMF_KIND_R8), pointer :: fldptr(:)!< Pointer to the 1D field + integer, intent(in) :: esmf_ind !< Index into 2D ESMF array + integer, optional , intent(out) :: rc !< Return code + + ! local variables + real(ESMF_KIND_R8), pointer :: fldptr2d(:,:)!< Pointer to the 1D field + type(ESMF_Field) :: lfield + integer :: lrc + character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' + + call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=lrc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (.not. associated(fldptr)) allocate(fldptr(size(fldptr2d,2))) + fldptr = fldptr2d(esmf_ind, :) + + if (present(rc)) rc = lrc + +end subroutine State_GetFldPtr_1d_from_2d + !> Get field pointer 2D subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) type(ESMF_State) , intent(in) :: State !< ESMF state @@ -676,7 +865,7 @@ subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) end subroutine State_GetFldPtr_2d !> Map 2d import state field to output array -subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum, areacor, rc) +subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum, areacor, esmf_ind, rc) type(ESMF_State) , intent(in) :: state !< ESMF state character(len=*) , intent(in) :: fldname !< Field name integer , intent(in) :: isc !< The start i-index of cell centers within @@ -691,18 +880,25 @@ subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum logical, optional , intent(in) :: do_sum !< If true, sums the data real (ESMF_KIND_R8), optional, intent(in) :: areacor(:) !< flux area correction factors !! applicable to meshes + integer, optional, intent(in) :: esmf_ind integer , intent(out) :: rc !< Return code ! local variables type(ESMF_StateItem_Flag) :: itemFlag integer :: n, i, j, i1, j1 integer :: lbnd1,lbnd2 + logical :: do_sum_loc real(ESMF_KIND_R8), pointer :: dataPtr1d(:) real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_2d)' ! ---------------------------------------------- rc = ESMF_SUCCESS + if (present(do_sum)) then + do_sum_loc = do_sum + else + do_sum_loc = .false. + endif call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then @@ -710,7 +906,11 @@ subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum if (geomtype == ESMF_GEOMTYPE_MESH) then ! get field pointer - call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (present(esmf_ind)) then + call state_getfldptr(state, trim(fldname), esmf_ind, dataptr1d, rc) + else + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + endif if (ChkErr(rc,__LINE__,u_FILE_u)) return ! determine output array and apply area correction if present @@ -718,23 +918,23 @@ subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum do j = jsc,jec do i = isc,iec n = n + 1 - if (present(do_sum)) then + if (do_sum_loc) then if (present(areacor)) then output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) else output(i,j) = output(i,j) + dataPtr1d(n) - end if + endif else if (present(areacor)) then output(i,j) = dataPtr1d(n) * areacor(n) else output(i,j) = dataPtr1d(n) - end if + endif endif enddo enddo - else if (geomtype == ESMF_GEOMTYPE_GRID) then + elseif (geomtype == ESMF_GEOMTYPE_GRID) then call state_getfldptr(state, trim(fldname), dataptr2d, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -746,7 +946,7 @@ subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum j1 = j + lbnd2 - jsc do i = isc, iec i1 = i + lbnd1 - isc - if (present(do_sum)) then + if (do_sum_loc) then output(i,j) = output(i,j) + dataPtr2d(i1,j1) else output(i,j) = dataPtr2d(i1,j1) @@ -784,11 +984,17 @@ subroutine State_GetImport_3d(state, fldname, isc, iec, jsc, jec, lbd, ubd, outp type(ESMF_StateItem_Flag) :: itemFlag integer :: n, i, j, i1, j1, u integer :: lbnd1,lbnd2 + logical :: do_sum_loc real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) character(len=*) , parameter :: subname='(MOM_cap_methods:state_getimport_3d)' ! ---------------------------------------------- rc = ESMF_SUCCESS + if (present(do_sum)) then + do_sum_loc = do_sum + else + do_sum_loc = .false. + endif call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then @@ -805,18 +1011,18 @@ subroutine State_GetImport_3d(state, fldname, isc, iec, jsc, jec, lbd, ubd, outp do j = jsc,jec do i = isc,iec n = n + 1 - if (present(do_sum)) then + if (do_sum_loc) then if (present(areacor)) then output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) * areacor(n) else output(i,j,u) = output(i,j,u) + dataPtr2d(u,n) - end if + endif else if (present(areacor)) then output(i,j,u) = dataPtr2d(u,n) * areacor(n) else output(i,j,u) = dataPtr2d(u,n) - end if + endif endif enddo enddo @@ -887,7 +1093,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid do n = 1,(size(dataPtr1d)) dataPtr1d(n) = dataPtr1d(n) * areacor(n) enddo - end if + endif ! if a maskmap is provided, set exports of all eliminated cells to zero. if (associated(ocean_grid%Domain%maskmap)) then diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 9ac40daaa4..329f436e48 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -108,17 +108,18 @@ module MOM_ocean_model_nuopc !! a global max across ocean and non-ocean processors can be !! used to determine its value. real, pointer, dimension(:,:) :: & - t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) - s_surf => NULL(), & !< SSS on t-cell (psu) - u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. - v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. + t_surf => NULL(), & !< SST on t-cell (degrees Kelvin) + s_surf => NULL(), & !< SSS on t-cell (psu) + u_surf => NULL(), & !< i-velocity at the locations indicated by stagger, m/s. + v_surf => NULL(), & !< j-velocity at the locations indicated by stagger, m/s. sea_lev => NULL(), & !< Sea level in m after correction for surface pressure, - !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) - frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil - !! formation in the ocean. + !! i.e. dzt(1) + eta_t + patm/rho0/grav (m) + frazil =>NULL(), & !< Accumulated heating (in Joules/m^2) from frazil + !! formation in the ocean. melt_potential => NULL(), & !< Instantaneous heat used to melt sea ice (in J/m^2) - area => NULL(), & !< cell area of the ocean surface, in m2. - OBLD => NULL() !< Ocean boundary layer depth, in m. + area => NULL(), & !< cell area of the ocean surface, in m2. + OBLD => NULL(), & !< Ocean boundary layer depth, in m. + fco2_ocn => NULL() !< Ocean CO2 flux, in kg CO2/m^2/s type(coupler_2d_bc_type) :: fields !< A structure that may contain named !! arrays of tracer-related surface fields. integer :: avg_kount !< A count of contributions to running @@ -255,6 +256,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array + logical :: use_MARBL !< If true, allocate surface co2 array ! This include declares and sets the variable "version". @@ -378,12 +380,14 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", use_MARBL, & + default=.false., do_not_log=.true.) ! Consider using a run-time flag to determine whether to do the diagnostic ! vertical integrals, since the related 3-d sums are not negligible in cost. call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & do_integrals=.true., gas_fields_ocn=gas_fields_ocn, & - use_meltpot=use_melt_pot) + use_meltpot=use_melt_pot, use_marbl_tracers=use_MARBL) call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp, OS%use_waves) @@ -538,6 +542,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%grid, OS%US, OS%forcing_CSp) if (OS%fluxes%fluxes_used) then + + ! enable_averages() is necessary to post forcing fields to diagnostics + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) + if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, & @@ -781,7 +789,7 @@ subroutine ocean_model_end(Ocean_sfc, Ocean_state, Time, write_restart) type(time_type), intent(in) :: Time !< The model time, used for writing restarts. logical, intent(in) :: write_restart !< true => write restart file - if(write_restart)call ocean_model_save_restart(Ocean_state, Time) + if (write_restart) call ocean_model_save_restart(Ocean_state, Time) call diag_mediator_end(Time, Ocean_state%diag, end_diag_manager=.true.) call MOM_end(Ocean_state%MOM_CSp) if (Ocean_state%use_ice_shelf) call ice_shelf_end(Ocean_state%Ice_shelf_CSp) @@ -853,25 +861,19 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, endif call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) - allocate ( Ocean_sfc%t_surf (isc:iec,jsc:jec), & - Ocean_sfc%s_surf (isc:iec,jsc:jec), & - Ocean_sfc%u_surf (isc:iec,jsc:jec), & - Ocean_sfc%v_surf (isc:iec,jsc:jec), & - Ocean_sfc%sea_lev(isc:iec,jsc:jec), & - Ocean_sfc%area (isc:iec,jsc:jec), & - Ocean_sfc%OBLD (isc:iec,jsc:jec), & - Ocean_sfc%melt_potential(isc:iec,jsc:jec), & - Ocean_sfc%frazil (isc:iec,jsc:jec)) - - Ocean_sfc%t_surf = 0.0 ! time averaged sst (Kelvin) passed to atmosphere/ice model - Ocean_sfc%s_surf = 0.0 ! time averaged sss (psu) passed to atmosphere/ice models - Ocean_sfc%u_surf = 0.0 ! time averaged u-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%v_surf = 0.0 ! time averaged v-current (m/sec) passed to atmosphere/ice models - Ocean_sfc%sea_lev = 0.0 ! time averaged thickness of top model grid cell (m) plus patm/rho0/grav - Ocean_sfc%frazil = 0.0 ! time accumulated frazil (J/m^2) passed to ice model - Ocean_sfc%melt_potential = 0.0 ! time accumulated melt potential (J/m^2) passed to ice model - Ocean_sfc%OBLD = 0.0 ! ocean boundary layer depth, in m - Ocean_sfc%area = 0.0 + allocate(Ocean_sfc%t_surf (isc:iec,jsc:jec), & ! time averaged sst (Kelvin) passed to atmosphere/ice model + Ocean_sfc%s_surf (isc:iec,jsc:jec), & ! time averaged sss (psu) passed to atmosphere/ice models + Ocean_sfc%u_surf (isc:iec,jsc:jec), & ! time averaged u-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%v_surf (isc:iec,jsc:jec), & ! time averaged v-current (m/sec) passed to atmosphere/ice models + Ocean_sfc%sea_lev(isc:iec,jsc:jec), & ! time averaged thickness of top model grid cell (m) plus + ! patm/rho0/grav + Ocean_sfc%frazil (isc:iec,jsc:jec), & ! time accumulated frazil (J/m^2) passed to ice model + Ocean_sfc%melt_potential(isc:iec,jsc:jec), & ! time accumulated melt potential (J/m^2) passed to ice model + Ocean_sfc%area (isc:iec,jsc:jec), & + Ocean_sfc%OBLD (isc:iec,jsc:jec), & ! ocean boundary layer depth, in m + Ocean_sfc%fco2_ocn(isc:iec,jsc:jec), & ! time averaged co2 flux (kg/m^2/s) passed to atmosphere model + source=0.0) + Ocean_sfc%axes = diag%axesT1%handles !diag axes to be used by coupler tracer flux diagnostics if (present(gas_fields_ocn)) then @@ -968,6 +970,12 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ enddo ; enddo endif + if (allocated(sfc_state%fco2)) then + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + Ocean_sfc%fco2_ocn(i,j) = US%RZ_T_to_kg_m2s * sfc_state%fco2(i+i0,j+j0) + enddo ; enddo + endif + if (Ocean_sfc%stagger == AGRID) then do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd Ocean_sfc%u_surf(i,j) = G%mask2dT(i+i0,j+j0) * US%L_T_to_m_s * & diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index d699697140..3e8f80e265 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -38,6 +38,8 @@ module MOM_surface_forcing_nuopc use user_revise_forcing, only : user_alter_forcing, user_revise_forcing_init use user_revise_forcing, only : user_revise_forcing_CS use iso_fortran_env, only : int64 +use MARBL_forcing_mod, only : marbl_forcing_CS, MARBL_forcing_init +use MARBL_forcing_mod, only : convert_driver_fields_to_forcings implicit none ; private @@ -79,6 +81,7 @@ module MOM_surface_forcing_nuopc !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. logical :: use_CFC !< enables the MOM_CFC_cap tracer package. + logical :: use_marbl_tracers !< enables the MARBL tracer package. logical :: enthalpy_cpl !< Controls if enthalpy terms are provided by the coupler or computed !! internally. real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] @@ -152,6 +155,8 @@ module MOM_surface_forcing_nuopc type(MOM_restart_CS), pointer :: restart_CSp => NULL() type(user_revise_forcing_CS), pointer :: urf_CS => NULL() + + type(marbl_forcing_CS), pointer :: marbl_forcing_CSp => NULL() !< parameters for getting MARBL forcing end type surface_forcing_CS !> Structure corresponding to forcing, but with the elements, units, and conventions @@ -186,6 +191,19 @@ module MOM_surface_forcing_nuopc !< on ocean surface [Pa] real, pointer, dimension(:,:) :: ice_fraction =>NULL() !< fractional ice area [nondim] real, pointer, dimension(:,:) :: u10_sqr =>NULL() !< wind speed squared at 10m [m2/s2] + real, pointer, dimension(:,:) :: nhx_dep =>NULL() !< Nitrogen deposition [kg/m^2/s] + real, pointer, dimension(:,:) :: noy_dep =>NULL() !< Nitrogen deposition [kg/m^2/s] + real, pointer, dimension(:,:) :: atm_co2_prog =>NULL() !< Prognostic atmospheric co2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_co2_diag =>NULL() !< Diagnostic atmospheric co2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_fine_dust_flux =>NULL() !< Fine dust flux from atmosphere [kg/m^2/s] + real, pointer, dimension(:,:) :: atm_coarse_dust_flux =>NULL() !< Coarse dust flux from atmosphere [kg/m^2/s] + real, pointer, dimension(:,:) :: seaice_dust_flux =>NULL() !< Dust flux from seaice [kg/m^2/s] + real, pointer, dimension(:,:) :: atm_bc_flux =>NULL() !< Black carbon flux from atmosphere [kg/m^2/s] + real, pointer, dimension(:,:) :: seaice_bc_flux =>NULL() !< Black carbon flux from seaice [kg/m^2/s] + real, pointer, dimension(:,:) :: afracr =>NULL() + real, pointer, dimension(:,:) :: swnet_afracr =>NULL() + real, pointer, dimension(:,:,:) :: swpen_ifrac_n =>NULL() + real, pointer, dimension(:,:,:) :: ifrac_n =>NULL() real, pointer, dimension(:,:) :: mi =>NULL() !< mass of ice [kg/m2] real, pointer, dimension(:,:) :: ice_rigidity =>NULL() !< rigidity of the sea ice, sea-ice and !! ice-shelves, expressed as a coefficient @@ -208,6 +226,10 @@ module MOM_surface_forcing_nuopc !! flux-exchange code, based on what the sea-ice !! model is providing. Otherwise, the value from !! the surface_forcing_CS is used. + + ! Forcing when receiving multiple ice categories from CMEPS + integer :: ice_ncat !< Number of ice categories coming from coupler + !! (1 => not using separate categories) end type ice_ocean_boundary_type integer :: id_clock_forcing @@ -297,8 +319,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & - cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) - !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) + cfc=CS%use_CFC, marbl=CS%use_marbl_tracers, hevap=CS%enthalpy_cpl, & + tau_mag=.true., ice_ncat=IOB%ice_ncat) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -561,6 +583,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, enddo ; enddo + ! Copy MARBL-specific IOB fields into fluxes; also set some MARBL-specific forcings to other values + ! (constants, values from netCDF, etc) + call convert_driver_fields_to_forcings(IOB%atm_fine_dust_flux, IOB%atm_coarse_dust_flux, & + IOB%seaice_dust_flux, IOB%atm_bc_flux, IOB%seaice_bc_flux, & + IOB%nhx_dep, IOB%noy_dep, IOB%atm_co2_prog, IOB%atm_co2_diag, & + IOB%afracr, IOB%swnet_afracr, IOB%ifrac_n, IOB%swpen_ifrac_n, & + Time, G, US, i0, j0, fluxes, CS%marbl_forcing_CSp) + ! wave to ocean coupling if ( associated(IOB%lamult)) then do j=js,je; do i=is,ie @@ -1209,6 +1239,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "USE_CFC_CAP", CS%use_CFC, & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "ENTHALPY_FROM_COUPLER", CS%enthalpy_cpl, & "If True, the heat (enthalpy) associated with mass entering/leaving the "//& "ocean is provided via coupler.", default=.false.) @@ -1388,6 +1421,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call data_override_init(Ocean_domain_in=G%Domain%mpp_domain) endif + ! Set up MARBL forcing control structure + call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + CS%marbl_forcing_CSp) + if (present(restore_salt)) then ; if (restore_salt) then salt_file = trim(CS%inputdir) // trim(CS%salt_restore_file) CS%srestore_handle = init_external_field(salt_file, CS%salt_restore_var_name, domain=G%Domain%mpp_domain) @@ -1496,6 +1533,60 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks endif + ! MARBL forcing + if (associated(iobt%atm_fine_dust_flux)) then + chks = field_chksum(iobt%atm_fine_dust_flux) + if (root) write(outunit,110) 'iobt%atm_fine_dust_flux ', chks + endif + if (associated(iobt%atm_coarse_dust_flux)) then + chks = field_chksum(iobt%atm_coarse_dust_flux) + if (root) write(outunit,110) 'iobt%atm_coarse_dust_flux ', chks + endif + if (associated(iobt%seaice_dust_flux)) then + chks = field_chksum(iobt%seaice_dust_flux) + if (root) write(outunit,110) 'iobt%seaice_dust_flux ', chks + endif + if (associated(iobt%atm_bc_flux)) then + chks = field_chksum(iobt%atm_bc_flux) + if (root) write(outunit,110) 'iobt%atm_bc_flux ', chks + endif + if (associated(iobt%seaice_bc_flux)) then + chks = field_chksum(iobt%seaice_bc_flux) + if (root) write(outunit,110) 'iobt%seaice_bc_flux ', chks + endif + if (associated(iobt%nhx_dep)) then + chks = field_chksum(iobt%nhx_dep) + if (root) write(outunit,100) 'iobt%nhx_dep ', chks + endif + if (associated(iobt%noy_dep)) then + chks = field_chksum(iobt%noy_dep) + if (root) write(outunit,100) 'iobt%noy_dep ', chks + endif + if (associated(iobt%atm_co2_prog)) then + chks = field_chksum(iobt%atm_co2_prog) + if (root) write(outunit,110) 'iobt%atm_co2_prog ', chks + endif + if (associated(iobt%atm_co2_diag)) then + chks = field_chksum(iobt%atm_co2_diag) + if (root) write(outunit,110) 'iobt%atm_co2_diag ', chks + endif + if (associated(iobt%afracr)) then + chks = field_chksum(iobt%afracr) + if (root) write(outunit,100) 'iobt%afracr ', chks + endif + if (associated(iobt%swnet_afracr)) then + chks = field_chksum(iobt%swnet_afracr) + if (root) write(outunit,110) 'iobt%swnet_afracr ', chks + endif + if (associated(iobt%ifrac_n)) then + chks = field_chksum(iobt%ifrac_n) + if (root) write(outunit,100) 'iobt%ifrac_n ', chks + endif + if (associated(iobt%swpen_ifrac_n)) then + chks = field_chksum(iobt%swpen_ifrac_n) + if (root) write(outunit,110) 'iobt%swpen_ifrac_n ', chks + endif + ! enthalpy if (associated(iobt%hrofl)) then chks = field_chksum( iobt%hrofl ) ; if (root) write(outunit,100) 'iobt%hrofl ', chks @@ -1517,6 +1608,7 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) +110 FORMAT(" CHECKSUM::",A30," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/config_src/drivers/nuopc_cap/time_utils.F90 b/config_src/drivers/nuopc_cap/time_utils.F90 index 81efcd2765..46f922d5bf 100644 --- a/config_src/drivers/nuopc_cap/time_utils.F90 +++ b/config_src/drivers/nuopc_cap/time_utils.F90 @@ -130,7 +130,7 @@ function fms2esmf_time(time, calkind) integer :: rc - if(present(calkind)) then + if (present(calkind)) then l_calkind = calkind else l_calkind = fms2esmf_cal(fms_get_calendar_type()) @@ -154,7 +154,7 @@ function string_to_date(string, rc) ! Local variables integer :: yr,mon,day,hr,min,sec - if(present(rc)) rc = ESMF_SUCCESS + if (present(rc)) rc = ESMF_SUCCESS read(string, '(I4.4,I2.2,I2.2,".",I2.2,I2.2,I2.2)') yr, mon, day, hr, min, sec string_to_date = set_date(yr, mon, day, hr, min, sec) diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index d17db5a9a1..3a8303e561 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -56,6 +56,8 @@ module MOM_surface_forcing use BFB_surface_forcing, only : BFB_surface_forcing_init, BFB_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_surface_forcing_init, dumbbell_surface_forcing_CS use dumbbell_surface_forcing, only : dumbbell_buoyancy_forcing +use MARBL_forcing_mod, only : marbl_forcing_CS, MARBL_forcing_init +use MARBL_forcing_mod, only : convert_driver_fields_to_forcings implicit none ; private @@ -116,6 +118,7 @@ module MOM_surface_forcing !! Dates before 20190101 use original answers. !! Dates after 20190101 use a form of the gyre wind stresses that are !! rotationally invariant and more likely to be the same between compilers. + logical :: use_marbl_tracers !< If true, allocate memory for forcing needed by MARBL logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the !! gustless wind friction velocity. ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile @@ -216,6 +219,7 @@ module MOM_surface_forcing type(MESO_surface_forcing_CS), pointer :: MESO_forcing_CSp => NULL() type(idealized_hurricane_CS), pointer :: idealized_hurricane_CSp => NULL() type(SCM_CVmix_tests_CS), pointer :: SCM_CVmix_tests_CSp => NULL() + type(marbl_forcing_CS), pointer :: marbl_forcing_CSp => NULL() !>@} end type surface_forcing_CS @@ -255,7 +259,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US ! Allocate memory for the mechanical and thermodynamic forcing fields. call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) - call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, tau_mag=CS%nonBous, & + call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, marbl=CS%use_marbl_tracers, tau_mag=CS%nonBous, & fix_accum_bug=CS%fix_ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then @@ -351,6 +355,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif endif + if (CS%use_marbl_tracers) then + call MARBL_forcing_from_data_override(fluxes, day_center, G, US, CS) + endif + if (associated(CS%tracer_flow_CSp)) then call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, CS%Rho0, & CS%tracer_flow_CSp) @@ -1542,6 +1550,94 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call callTree_leave("buoyancy_forcing_linear") end subroutine buoyancy_forcing_linear + +! Sets the necessary MARBL forcings via the data override facility. +subroutine MARBL_forcing_from_data_override(fluxes, day, G, US, CS) + type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields + type(time_type), intent(in) :: day !< The time of the fluxes + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(surface_forcing_CS), pointer :: CS !< pointer to control structure returned by + !! a previous surface_forcing_init call + ! Local variables + real, pointer, dimension(:,:) :: atm_co2_prog =>NULL() !< Prognostic atmospheric CO2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_co2_diag =>NULL() !< Diagnostic atmospheric CO2 concentration [ppm] + real, pointer, dimension(:,:) :: atm_fine_dust_flux =>NULL() !< Fine dust flux from atmosphere [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: atm_coarse_dust_flux =>NULL() !< Coarse dust flux from atmosphere [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: seaice_dust_flux =>NULL() !< Dust flux from seaice [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: atm_bc_flux =>NULL() !< Black carbon flux from atmosphere [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: seaice_bc_flux =>NULL() !< Black carbon flux from seaice [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: nhx_dep =>NULL() !< Nitrogen deposition [kg/m^2/s ~> RZ/T] + real, pointer, dimension(:,:) :: noy_dep =>NULL() !< Nitrogen deposition [kg/m^2/s ~> RZ/T] + integer :: isc, iec, jsc, jec + + ! Necessary null pointers for arguments to convert_driver_fields_to_forcings() + ! Since they are null, MARBL will not use multiple ice categories + real, pointer, dimension(:,:) :: afracr =>NULL() + real, pointer, dimension(:,:) :: swnet_afracr =>NULL() + real, pointer, dimension(:,:,:) :: swpen_ifrac_n =>NULL() + real, pointer, dimension(:,:,:) :: ifrac_n =>NULL() + + call callTree_enter("MARBL_forcing_from_data_override, MOM_surface_forcing.F90") + + if (.not.CS%dataOverrideIsInitialized) then + call data_override_init(G%Domain) + CS%dataOverrideIsInitialized = .True. + endif + + ! Allocate memory for pointers + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + allocate ( atm_co2_prog (isc:iec,jsc:jec), & + atm_co2_diag (isc:iec,jsc:jec), & + atm_fine_dust_flux (isc:iec,jsc:jec), & + atm_coarse_dust_flux (isc:iec,jsc:jec), & + seaice_dust_flux (isc:iec,jsc:jec), & + atm_bc_flux (isc:iec,jsc:jec), & + seaice_bc_flux (isc:iec,jsc:jec), & + nhx_dep (isc:iec,jsc:jec), & + noy_dep (isc:iec,jsc:jec), & + source=0.0) + + + ! fluxes used directly as MARBL inputs + ! (should be scaled) + call data_override(G%Domain, 'ice_fraction', fluxes%ice_fraction, day) + call data_override(G%Domain, 'u10_sqr', fluxes%u10_sqr, day, scale=US%m_s_to_L_T**2) + + ! fluxes used to compute MARBL inputs + ! These are kept in physical units, and will be scaled appropriately in + ! convert_driver_fields_to_forcings() + call data_override(G%Domain, 'atm_co2_prog', atm_co2_prog, day) + call data_override(G%Domain, 'atm_co2_diag', atm_co2_diag, day) + call data_override(G%Domain, 'atm_fine_dust_flux', atm_fine_dust_flux, day) + call data_override(G%Domain, 'atm_coarse_dust_flux', atm_coarse_dust_flux, day) + call data_override(G%Domain, 'atm_bc_flux', atm_bc_flux, day) + call data_override(G%Domain, 'seaice_dust_flux', seaice_dust_flux, day) + call data_override(G%Domain, 'seaice_bc_flux', seaice_bc_flux, day) + call data_override(G%Domain, 'nhx_dep', nhx_dep, day) + call data_override(G%Domain, 'noy_dep', noy_dep, day) + + call convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust_flux, & + seaice_dust_flux, atm_bc_flux, seaice_bc_flux, & + nhx_dep, noy_dep, atm_co2_prog, atm_co2_diag, & + afracr, swnet_afracr, ifrac_n, swpen_ifrac_n, & + day, G, US, 0, 0, fluxes, CS%marbl_forcing_CSp) + + deallocate ( atm_co2_prog, & + atm_co2_diag, & + atm_fine_dust_flux, & + atm_coarse_dust_flux, & + seaice_dust_flux, & + atm_bc_flux, & + seaice_bc_flux, & + nhx_dep, & + noy_dep) + + call callTree_leave("MARBL_forcing_from_data_override") + +end subroutine MARBL_forcing_from_data_override + + !> Save a restart file for the forcing fields subroutine forcing_save_restart(CS, G, Time, directory, time_stamped, & filename_suffix) @@ -1739,7 +1835,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "The file with the surface salinity toward which to "//& "restore in the variable given by SSS_RESTORE_VAR.", & fail_if_missing=.true.) - if (CS%archaic_OMIP_file) then CS%SST_restore_var = "TEMP" ; CS%SSS_restore_var = "SALT" else @@ -1952,6 +2047,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call read_netCDF_data(filename, 'gustiness', CS%gust, G%Domain, & rescale=US%Pa_to_RLZ_T2) ! units in file should be [Pa] endif + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + default=.false., do_not_log=.true.) ! All parameter settings are now known. @@ -1978,6 +2075,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call SCM_CVmix_tests_surface_forcing_init(Time, G, param_file, CS%SCM_CVmix_tests_CSp) endif + ! Set up MARBL forcing control structure + call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + CS%marbl_forcing_CSp) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles) ! Set up any restart fields associated with the forcing. @@ -2037,6 +2138,7 @@ subroutine surface_forcing_end(CS, fluxes) if (associated(CS)) deallocate(CS) CS => NULL() + call callTree_leave("MARBL_forcing_from_data_override, MOM_surface_forcing.F90") end subroutine surface_forcing_end end module MOM_surface_forcing diff --git a/config_src/external/MARBL/README.md b/config_src/external/MARBL/README.md new file mode 100644 index 0000000000..f19f76dec8 --- /dev/null +++ b/config_src/external/MARBL/README.md @@ -0,0 +1,6 @@ +MARBL +===== + +These APIs reflect those for the MARBL library available at https://github.com/marbl-ecosys/MARBL + +The modules in this directory do not do any computations. They simply reflect the APIs of the above package. diff --git a/config_src/external/MARBL/marbl_constants_mod.F90 b/config_src/external/MARBL/marbl_constants_mod.F90 new file mode 100644 index 0000000000..7a1d44ba97 --- /dev/null +++ b/config_src/external/MARBL/marbl_constants_mod.F90 @@ -0,0 +1,11 @@ +!> A non-functioning template of the MARBL constants module +module marbl_constants_mod + + implicit none + private + + !> Molecular weight of iron + real, public, parameter :: molw_Fe = 55.845 + +end module marbl_constants_mod + diff --git a/config_src/external/MARBL/marbl_interface.F90 b/config_src/external/MARBL/marbl_interface.F90 new file mode 100644 index 0000000000..c31684597c --- /dev/null +++ b/config_src/external/MARBL/marbl_interface.F90 @@ -0,0 +1,134 @@ +!> A non-functioning template of the MARBL interface +module marbl_interface + + use MOM_error_handler, only : MOM_error, FATAL + use marbl_logging, only : marbl_log_type + use marbl_interface_public_types, only : marbl_forcing_fields_type + use marbl_interface_public_types, only : marbl_tracer_metadata_type + use marbl_interface_public_types, only : marbl_saved_state_type + use marbl_interface_public_types, only : marbl_diagnostics_type + use marbl_interface_public_types, only : marbl_domain_type + use marbl_interface_public_types, only : marbl_output_for_GCM_type + implicit none + private ! Only want marbl_interface_class to be public, not supporting functions + + !> A non-functioning template of the MARBL_interface class + !! + !> All variables are dummy representations of actual members of the real marbl_interface_class + !! that are used in the MARBL tracer routines. + type, public :: marbl_interface_class + type(marbl_log_type) :: StatusLog !< dummy log + type(marbl_forcing_fields_type), allocatable :: surface_flux_forcings(:) !< dummy forcing array + type(marbl_forcing_fields_type), allocatable :: interior_tendency_forcings(:) !< dummy forcing array + type(marbl_tracer_metadata_type), allocatable :: tracer_metadata(:) !< dummy metadata array + type(marbl_domain_type) :: domain !< dummy domain + type(marbl_saved_state_type) :: surface_flux_saved_state !< dummy saved state + type(marbl_saved_state_type) :: interior_tendency_saved_state !< dummy saved state + type(marbl_diagnostics_type) :: surface_flux_diags !< dummy diagnostics + type(marbl_diagnostics_type) :: interior_tendency_diags !< dummy diagnostics + type(marbl_output_for_GCM_type) :: surface_flux_output !< dummy output + type(marbl_output_for_GCM_type) :: interior_tendency_output !< dummy output + real, allocatable :: tracers(:,:) !< dummy tracer array + real, allocatable :: tracers_at_surface(:,:) !< dummy tracer surface array + real, allocatable :: bot_flux_to_tend(:) !< dummy array for bot flux to tendency wgts + real, allocatable :: surface_fluxes(:,:) !< dummy fluxes + real, allocatable :: interior_tendencies(:,:) !< dummy tendencies + contains + procedure, public :: put_setting !< dummy put_setting routine + procedure, public :: get_setting !< dummy get_setting routine + procedure, public :: init !< dummy routine + procedure, public :: surface_flux_compute !< dummy surface flux routine + procedure, public :: interior_tendency_compute !< dummy interior tendency routine + procedure, public :: add_output_for_GCM !< dummy add_output_for_GCM routine + procedure, public :: shutdown !< dummy shutdown routine + end type marbl_interface_class + + !> Error message that appears if the dummy interface is called + character(len=*), parameter :: error_msg = "MOM6 built the MARBL stubs rather than the full library" + +contains + + !> Dummy version of MARBL's put_setting() function + subroutine put_setting(self, str_in) + class(marbl_interface_class), intent(in) :: self + character(len=*), intent(in) :: str_in + + call MOM_error(FATAL, error_msg) + end subroutine put_setting + + !> Dummy version of MARBL's get_setting() function + subroutine get_setting(self, str_in, log_out) + class(marbl_interface_class), intent(in) :: self + character(len=*), intent(in) :: str_in + logical, intent(out) :: log_out + + call MOM_error(FATAL, error_msg) + end subroutine get_setting + + !> Dummy version of MARBL's init() function + subroutine init(self, & + gcm_num_levels, & + gcm_num_PAR_subcols, & + gcm_num_elements_surface_flux, & + gcm_delta_z, & + gcm_zw, & + gcm_zt, & + unit_system_opt, & + lgcm_has_global_ops) + + class(marbl_interface_class), intent(inout) :: self + integer, intent(in) :: gcm_num_levels + integer, intent(in) :: gcm_num_PAR_subcols + integer, intent(in) :: gcm_num_elements_surface_flux + real, intent(in) :: gcm_delta_z(gcm_num_levels) + real, intent(in) :: gcm_zw(gcm_num_levels) + real, intent(in) :: gcm_zt(gcm_num_levels) + character(len=*), intent(in) :: unit_system_opt + logical, intent(in) :: lgcm_has_global_ops + + call MOM_error(FATAL, error_msg) + end subroutine init + + !> Dummy version of MARBL's surface_flux_compute() function + subroutine surface_flux_compute(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine surface_flux_compute + + !> Dummy version of MARBL's interior_tendency_compute() function + subroutine interior_tendency_compute(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine interior_tendency_compute + + !> Dummy version of MARBL's add_output_for_GCM() function + subroutine add_output_for_GCM(self, num_elements, field_name, output_id, field_source, num_levels) + + class (marbl_interface_class), intent(inout) :: self + integer, intent(in) :: num_elements + character(len=*), intent(in) :: field_name + integer, intent(out) :: output_id + character(len=*), intent(out) :: field_source + integer, optional, intent(in) :: num_levels + + output_id = 0 + field_source = "" + + end subroutine add_output_for_GCM + + !> Dummy version of MARBL's shutdown() function + subroutine shutdown(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine shutdown + +end module marbl_interface diff --git a/config_src/external/MARBL/marbl_interface_public_types.F90 b/config_src/external/MARBL/marbl_interface_public_types.F90 new file mode 100644 index 0000000000..5c49ea1985 --- /dev/null +++ b/config_src/external/MARBL/marbl_interface_public_types.F90 @@ -0,0 +1,89 @@ +!> A non-functioning template of the public structures provided through MARBL interface +module marbl_interface_public_types + + use marbl_logging, only : marbl_log_type + + implicit none + private ! Only want a few types to be public + + !> A non-functioning template of MARBL diagnostic type + type :: marbl_single_diagnostic_type + character(len=0) :: long_name !< dummy name + character(len=0) :: short_name !< dummy name + character(len=0) :: units !< dummy units + character(len=0) :: vertical_grid !< dummy grid + logical :: compute_now !< dummy flag + logical :: ltruncated_vertical_extent !< dummy flag + integer :: ref_depth !< dummy depth + real, allocatable, dimension(:) :: field_2d !< dummy field + real, allocatable, dimension(:,:) :: field_3d !< dummy field + end type marbl_single_diagnostic_type + + !> A non-functioning template of MARBL diagnostic type + type, public :: marbl_diagnostics_type + type(marbl_single_diagnostic_type), dimension(:), pointer :: diags => NULL() !< dummy point + end type marbl_diagnostics_type + + !> A non-functioning template of MARBL saved state type + type :: marbl_single_saved_state_type + integer :: rank !< dummy rank + character(len=0) :: short_name !< dummy name + character(len=0) :: units !< dummy units + character(len=0) :: vertical_grid !< dummy grid + real, allocatable :: field_2d(:) !< dummy field + real, allocatable :: field_3d(:,:) !< dummy field + end type marbl_single_saved_state_type + + !> A non-functioning template of MARBL saved state type + type, public :: marbl_saved_state_type + integer :: saved_state_cnt !< dummy counter + type(marbl_single_saved_state_type), dimension(:), pointer :: state => NULL() !< dummy pointer + end type marbl_saved_state_type + + !> A non-functioning template of MARBL forcing metadata type + type :: marbl_forcing_fields_metadata_type + character(len=0) :: varname !< dummy name + end type marbl_forcing_fields_metadata_type + + !> A non-functioning template of MARBL forcing type + type, public :: marbl_forcing_fields_type + type(marbl_forcing_fields_metadata_type) :: metadata !< dummy metadata + real, pointer :: field_0d(:) => NULL() !< dummy pointer + real, pointer :: field_1d(:,:) => NULL() !< dummy pointer + end type marbl_forcing_fields_type + + !> A non-functioning template of MARBL tracer metadata type + type, public :: marbl_tracer_metadata_type + character(len=0) :: short_name !< dummy name + character(len=0) :: long_name !< dummy name + character(len=0) :: units !< dummy units + end type marbl_tracer_metadata_type + + !> A non-functioning template of MARBL domain type + type, public :: marbl_domain_type + integer :: kmt !< dummy index + integer :: km !< dummy index + real, allocatable :: zt(:) !< dummy depths + real, allocatable :: zw(:) !< dummy depths + real, allocatable :: delta_z(:) !< dummy thicknesses + end type marbl_domain_type + + !> A non-functioning template of MARBL single output type + type, public :: marbl_single_output_type + ! marbl_single_output : + ! a private type, this contains both the metadata and + ! the actual data for a single field computed in either + ! surface_flux_compute() or interior_tendency_compute() + ! that needs to be passed to the GCM / flux coupler. + ! Data must be accessed via the marbl_output_for_GCM_type + ! data structure. + real, allocatable, dimension(:) :: forcing_field_0d !< dummy forcing_field_0d + real, allocatable, dimension(:,:) :: forcing_field_1d !< forcing_field_1d + end type marbl_single_output_type + + !> A non-functioning template of MARBL output for GCM type + type, public :: marbl_output_for_GCM_type + type(marbl_single_output_type), dimension(:), pointer :: outputs_for_GCM => NULL() !< dummy outputs_for_GCM + end type marbl_output_for_GCM_type + +end module marbl_interface_public_types \ No newline at end of file diff --git a/config_src/external/MARBL/marbl_logging.F90 b/config_src/external/MARBL/marbl_logging.F90 new file mode 100644 index 0000000000..906d881f0e --- /dev/null +++ b/config_src/external/MARBL/marbl_logging.F90 @@ -0,0 +1,38 @@ +!> A non-functioning template of the MARBL logging module +module marbl_logging + + implicit none + private + + !> A non-functioning template of the marbl status log type + type, public :: marbl_status_log_entry_type + integer :: ElementInd !< dummy index + logical :: lonly_master_writes !< dummy flag + character(len=0) :: LogMessage !< dummy message + type(marbl_status_log_entry_type), pointer :: next !< dummy pointer + end type marbl_status_log_entry_type + + !> A non-functioning template of the marbl status log type + type, public :: marbl_log_type + logical, public :: labort_marbl !< dummy flag + type(marbl_status_log_entry_type), pointer :: FullLog !< dummy pointer + contains + procedure, public :: log_error_trace !< dummy trace routine + procedure, public :: erase !< dummy erase routine + end type marbl_log_type + +contains + + !> dummy trace routine + subroutine log_error_trace(self, RoutineName, CodeLoc, ElemInd) + class(marbl_log_type), intent(inout) :: self + character(len=*), intent(in) :: RoutineName, CodeLoc + integer, optional, intent(in) :: ElemInd + end subroutine log_error_trace + + !> dummy erase routine + subroutine erase(self) + class(marbl_log_type), intent(inout) :: self + end subroutine erase + +end module marbl_logging \ No newline at end of file diff --git a/pkg/CVMix-src b/pkg/CVMix-src index 9423197f89..52aac958e0 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit 9423197f894112edfcb1502245f7d7b873d551f9 +Subproject commit 52aac958e05cdb2471dc73f9ef7fb4e816c550f2 diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b8b3174b4a..6e4969142e 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -53,6 +53,12 @@ module MOM_forcing_type module procedure allocate_mech_forcing_from_ref end interface allocate_mech_forcing +!> Allocate arrays if optional flag is present and true (works for 2D and 3D) +interface myAlloc + module procedure myAlloc_2d + module procedure myAlloc_3d +end interface myAlloc + !> Determine the friction velocity from a forcing type or a mechanical forcing type. interface find_ustar module procedure find_ustar_fluxes @@ -212,6 +218,19 @@ module MOM_forcing_type ice_fraction => NULL(), & !< fraction of sea ice coverage at h-cells, from 0 to 1 [nondim]. u10_sqr => NULL() !< wind magnitude at 10 m squared [L2 T-2 ~> m2 s-2] + ! Forcing fields required for MARBL + real, pointer, dimension(:,:) :: & + noy_dep => NULL(), & !< NOy Deposition [conc Z T-1 ~> conc m s-1] + nhx_dep => NULL(), & !< NHx Deposition [conc Z T-1 ~> conc m s-1] + atm_co2 => NULL(), & !< Atmospheric CO2 Concentration [ppm] + atm_alt_co2 => NULL(), & !< Alternate atmospheric CO2 Concentration [ppm] + dust_flux => NULL(), & !< Flux of dust into the ocean [R Z T-1 ~> kgN m-2 s-1] + iron_flux => NULL() !< Flux of dust into the ocean [conc Z T-1 ~> conc m s-1] + + real, pointer, dimension(:,:,:) :: & + fracr_cat => NULL(), & !< per-category ice fraction + qsw_cat => NULL() !< per-category shortwave + real, pointer, dimension(:,:) :: & lamult => NULL() !< Langmuir enhancement factor [nondim] @@ -3202,8 +3221,9 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & - shelf, iceberg, salt, fix_accum_bug, cfc, waves, & - shelf_sfc_accumulation, lamult, hevap, tau_mag) + shelf, iceberg, salt, fix_accum_bug, cfc, marbl, & + waves, shelf_sfc_accumulation, lamult, hevap, & + ice_ncat, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -3217,6 +3237,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & !! accumulation of ustar_gustless logical, optional, intent(in) :: cfc !< If present and true, allocate fields needed !! for cfc surface fluxes + logical, optional, intent(in) :: marbl !< If present and true, allocate fields needed + !! for MARBL surface fluxes logical, optional, intent(in) :: waves !< If present and true, allocate wave fields logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, !! then allocate surface flux deposition from the atmosphere @@ -3225,6 +3247,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: hevap !< If present and true, allocate heat content evap. !! This field must be allocated when enthalpy is provided !! via coupler. + integer, optional, intent(in) :: ice_ncat !< number of ice categories logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields ! Local variables @@ -3291,20 +3314,37 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc) endif; endif - !These fields should only on allocated when iceberg area is being passed through the coupler. + !These fields should only be allocated when iceberg area is being passed through the coupler. call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg) call myAlloc(fluxes%area_berg,isd,ied,jsd,jed, iceberg) call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) - !These fields should only on allocated when USE_CFC_CAP is activated. + !These fields should only be allocated when USE_CFC_CAP is activated. call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, cfc) - !These fields should only on allocated when wave coupling is activated. + !These fields should only be allocated when wave coupling is activated. call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, waves) call myAlloc(fluxes%lamult,isd,ied,jsd,jed, lamult) if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug + + !These fields should only be allocated when USE_MARBL is activated. + call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%noy_dep,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%nhx_dep,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_co2,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_alt_co2,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%dust_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%iron_flux,isd,ied,jsd,jed, marbl) + + ! These fields should only be allocated when receiving multiple ice categories + if (present(ice_ncat)) then + call myAlloc(fluxes%fracr_cat,isd,ied,jsd,jed,1,ice_ncat+1, ice_ncat > 0) + call myAlloc(fluxes%qsw_cat,isd,ied,jsd,jed,1,ice_ncat+1, ice_ncat > 0) + endif + end subroutine allocate_forcing_by_group !> Allocate elements of a new forcing type based on their status in an existing type. @@ -3495,7 +3535,7 @@ end subroutine get_mech_forcing_groups !> Allocates and zeroes-out array. -subroutine myAlloc(array, is, ie, js, je, flag) +subroutine myAlloc_2d(array, is, ie, js, je, flag) real, dimension(:,:), pointer :: array !< Array to be allocated integer, intent(in) :: is !< Start i-index integer, intent(in) :: ie !< End i-index @@ -3506,7 +3546,22 @@ subroutine myAlloc(array, is, ie, js, je, flag) if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then allocate(array(is:ie,js:je), source=0.0) endif ; endif ; endif -end subroutine myAlloc +end subroutine myAlloc_2d + +subroutine myAlloc_3d(array, is, ie, js, je, ks, ke, flag) + real, dimension(:,:,:), pointer :: array !< Array to be allocated + integer, intent(in) :: is !< Start i-index + integer, intent(in) :: ie !< End i-index + integer, intent(in) :: js !< Start j-index + integer, intent(in) :: je !< End j-index + integer, intent(in) :: ks !< Start k-index + integer, intent(in) :: ke !< End k-index + logical, optional, intent(in) :: flag !< Flag to indicate to allocate + + if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then + allocate(array(is:ie,js:je,ks:ke), source=0.0) + endif ; endif ; endif +end subroutine myAlloc_3d !> Deallocate the forcing type subroutine deallocate_forcing_type(fluxes) @@ -3562,6 +3617,14 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%mass_berg)) deallocate(fluxes%mass_berg) if (associated(fluxes%ice_fraction)) deallocate(fluxes%ice_fraction) if (associated(fluxes%u10_sqr)) deallocate(fluxes%u10_sqr) + if (associated(fluxes%noy_dep)) deallocate(fluxes%noy_dep) + if (associated(fluxes%nhx_dep)) deallocate(fluxes%nhx_dep) + if (associated(fluxes%atm_co2)) deallocate(fluxes%atm_co2) + if (associated(fluxes%atm_alt_co2)) deallocate(fluxes%atm_alt_co2) + if (associated(fluxes%dust_flux)) deallocate(fluxes%dust_flux) + if (associated(fluxes%iron_flux)) deallocate(fluxes%iron_flux) + if (associated(fluxes%fracr_cat)) deallocate(fluxes%fracr_cat) + if (associated(fluxes%qsw_cat)) deallocate(fluxes%qsw_cat) call coupler_type_destructor(fluxes%tr_fluxes) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 0eab1a5b17..c432e73223 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -57,7 +57,8 @@ module MOM_variables ocean_heat, & !< The total heat content of the ocean in [C R Z ~> degC kg m-2]. ocean_salt, & !< The total salt content of the ocean in [1e-3 S R Z ~> kgSalt m-2]. taux_shelf, & !< The zonal stresses on the ocean under shelves [R L Z T-2 ~> Pa]. - tauy_shelf !< The meridional stresses on the ocean under shelves [R L Z T-2 ~> Pa]. + tauy_shelf, & !< The meridional stresses on the ocean under shelves [R L Z T-2 ~> Pa]. + fco2 !< CO2 flux from the ocean to the atmosphere [R Z T-1 ~> kgCO2 m-2 s-1] logical :: T_is_conT = .false. !< If true, the temperature variable SST is actually the !! conservative temperature in [C ~> degC]. logical :: S_is_absS = .false. !< If true, the salinity variable SSS is actually the @@ -337,7 +338,7 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil) + omit_frazil, use_marbl_tracers) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. @@ -354,9 +355,10 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler + logical, optional, intent(in) :: use_marbl_tracers !< If true, allocate the space for CO2 flux from MARBL ! local variables - logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil, alloc_fco2 integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -369,6 +371,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil + alloc_fco2 = .false. ; if (present(use_marbl_tracers)) alloc_fco2 = use_marbl_tracers if (sfc_state%arrays_allocated) return @@ -408,6 +411,10 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & call coupler_type_spawn(gas_fields_ocn, sfc_state%tr_fields, & (/is,is,ie,ie/), (/js,js,je,je/), as_needed=.true.) + if (alloc_fco2) then + allocate(sfc_state%fco2(isd:ied,jsd:jed), source=0.0) + endif + sfc_state%arrays_allocated = .true. end subroutine allocate_surface_state @@ -429,6 +436,7 @@ subroutine deallocate_surface_state(sfc_state) if (allocated(sfc_state%ocean_mass)) deallocate(sfc_state%ocean_mass) if (allocated(sfc_state%ocean_heat)) deallocate(sfc_state%ocean_heat) if (allocated(sfc_state%ocean_salt)) deallocate(sfc_state%ocean_salt) + if (allocated(sfc_state%fco2)) deallocate(sfc_state%fco2) call coupler_type_destructor(sfc_state%tr_fields) sfc_state%arrays_allocated = .false. diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index e131e8db9d..9c725f7f1a 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -10,13 +10,27 @@ module MOM_interpolate use MOM_interp_infra, only : horiz_interp_type, get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_interp_infra, only : external_field -use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(<), operator(>) implicit none ; private +!> Data type used to store information about forcing datasets that are time series +!! E.g. how do we align the data in the model with the time axis in the file? +type, public :: forcing_timeseries_dataset + character(len=200) :: file_name !< name of file containing river flux forcing + logical :: l_time_varying !< .true. => forcing is dependent on model time, .false. => static forcing + ! logical :: l_FMS_modulo !< .true. => let FMS handle determining time level to read (e.g. for climatologies) + type(time_type) :: data_forcing !< convert data_forcing_year to time type + type(time_type) :: data_start !< convert data_start_year to time type + type(time_type) :: data_end !< convert data_end_year to time type + type(time_type) :: m2d_offset !< add to model time to get data time +end type forcing_timeseries_dataset + public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights public :: external_field +public :: forcing_timeseries_set_time_type_vars +public :: map_model_time_to_forcing_time !> Read a field based on model time, and rotate to the model domain. interface time_interp_external @@ -210,4 +224,65 @@ subroutine time_interp_external_3d(field, time, data_in, interp, & end subroutine time_interp_external_3d +!> Set time_type variables in forcing_timeseries_dataset type based on integer input +!! TODO: make this part of forcing_timeseries_dataset class if OO is okay in MOM6? +subroutine forcing_timeseries_set_time_type_vars(data_start_year, data_end_year, data_ref_year, & + model_ref_year, data_forcing_year, forcing_dataset) + + integer, intent(in) :: data_start_year !< first year of data to read + !! (this is ignored for static forcing) + integer, intent(in) :: data_end_year !< last year of data to read + !! (this is ignored for static forcing) + integer, intent(in) :: data_ref_year !< for time-varying forcing, align + !! data_ref_year in file with + !! model_ref_year in model + integer, intent(in) :: model_ref_year !< for time-varying forcing, align + !! data_ref_year in file with + !! model_ref_year in model + integer, intent(in) :: data_forcing_year !< for static forcing, read file at this + !! date (this is ignored for time-varying + !! forcing) + type(forcing_timeseries_dataset), intent(inout) :: forcing_dataset !< information about forcing file + + if (forcing_dataset%l_time_varying) then + forcing_dataset%data_start = real_to_time(year_to_sec(data_start_year)) + forcing_dataset%data_end = real_to_time(year_to_sec(data_end_year)) + forcing_dataset%m2d_offset = real_to_time(year_to_sec(data_ref_year - model_ref_year)) + else + forcing_dataset%data_forcing = real_to_time(year_to_sec(data_forcing_year)) + endif + +end subroutine forcing_timeseries_set_time_type_vars + +!> If necessary, apply an offset to convert from model time to forcing time and then +!! ensure result is within acceptable bounds +function map_model_time_to_forcing_time(Time, forcing_dataset) + + type(time_type), intent(in) :: Time !< Model time + type(forcing_timeseries_dataset), intent(in) :: forcing_dataset !< information about forcing file + type(time_type) :: map_model_time_to_forcing_time !< time to read forcing file + + if (forcing_dataset%l_time_varying) then + map_model_time_to_forcing_time = Time + forcing_dataset%m2d_offset + ! If Time + offset is not between data_start and data_end, use whichever of those values is closer + if (map_model_time_to_forcing_time < forcing_dataset%data_start) & + map_model_time_to_forcing_time = forcing_dataset%data_start + if (map_model_time_to_forcing_time > forcing_dataset%data_end) & + map_model_time_to_forcing_time = forcing_dataset%data_end + else + map_model_time_to_forcing_time = forcing_dataset%data_forcing + endif + +end function map_model_time_to_forcing_time + +!> real_to_time converts from seconds since 0001-01-01 to time_type so we need to convert from years -> seconds +function year_to_sec(year) + + integer, intent(in) :: year + real :: year_to_sec + + year_to_sec = 86400. * 365. * real(year-1) + +end function year_to_sec + end module MOM_interpolate diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 808430df2c..fa39971d70 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -36,7 +36,7 @@ module MOM_tracer_initialization_from_Z !> Initializes a tracer from a z-space data file, including any lateral regridding that is needed. subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_nam, & src_var_unit_conversion, src_var_record, homogenize, & - useALEremapping, remappingScheme, src_var_gridspec ) + useALEremapping, remappingScheme, src_var_gridspec, ongrid ) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -54,6 +54,9 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. !! This is not implemented yet. + logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated to + !! the model horizontal grid. In this case, only extrapolation + !! is performed by horiz_interp_and_extrap_tracer() ! Local variables real :: land_fill = 0.0 ! A value to use to replace missing values [CU ~> conc] real :: convert ! A conversion factor into the model's internal units [CU conc-1 ~> 1] @@ -111,10 +114,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "initial conditions.", default=.false.) call get_param(PF, mdl, "Z_INIT_ALE_REMAPPING", useALE, & "If True, then remap straight to model coordinate from file.",& - default=.true.) + default=.false.) call get_param(PF, mdl, "Z_INIT_REMAPPING_SCHEME", remapScheme, & "The remapping scheme to use if using Z_INIT_ALE_REMAPPING is True.", & - default="PLM") + default="PPM_IH4") call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -145,7 +148,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call horiz_interp_and_extrap_tracer(src_file, src_var_nam, recnum, & G, tr_z, mask_z, z_in, z_edges_in, missing_value, & - scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date) + scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=ongrid) kd = size(z_edges_in,1)-1 call pass_var(tr_z,G%Domain) diff --git a/src/parameterizations/MARBL b/src/parameterizations/MARBL new file mode 120000 index 0000000000..c78d57b86a --- /dev/null +++ b/src/parameterizations/MARBL @@ -0,0 +1 @@ +../../pkg/MARBL/src/ \ No newline at end of file diff --git a/src/tracer/MARBL_forcing_mod.F90 b/src/tracer/MARBL_forcing_mod.F90 new file mode 100644 index 0000000000..9375f9ab08 --- /dev/null +++ b/src/tracer/MARBL_forcing_mod.F90 @@ -0,0 +1,378 @@ +!> This module provides a common datatype to provide forcing for MARBL tracers +!! regardless of driver +module MARBL_forcing_mod + +!! This module exists to house code used by multiple drivers in config_src/ +!! for passing forcing fields to MARBL +!! (This comment can go in the wiki on the NCAR fork?) + +use MOM_diag_mediator, only : safe_alloc_ptr, diag_ctrl, register_diag_field, post_data +use MOM_time_manager, only : time_type +use MOM_error_handler, only : MOM_error, WARNING, FATAL +use MOM_file_parser, only : get_param, log_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_io, only : slasher +use marbl_constants_mod, only : molw_Fe +use MOM_forcing_type, only : forcing + +implicit none ; private + +#include + +public :: MARBL_forcing_init +public :: convert_driver_fields_to_forcings + +!> Data type used to store diagnostic index returned from register_diag_field() +!! For the forcing fields that can be written via post_data() +type, private :: marbl_forcing_diag_ids + integer :: atm_fine_dust !< Atmospheric fine dust component of dust_flux + integer :: atm_coarse_dust !< Atmospheric coarse dust component of dust_flux + integer :: atm_bc !< Atmospheric black carbon component of iron_flux + integer :: ice_dust !< Sea-ice dust component of dust_flux + integer :: ice_bc !< Sea-ice black carbon component of iron_flux +end type marbl_forcing_diag_ids + +!> Control structure for this module +type, public :: marbl_forcing_CS + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + + real :: dust_ratio_thres !< coarse/fine dust ratio threshold + real :: dust_ratio_to_fe_bioavail_frac !< ratio of dust to iron bioavailability fraction + real :: fe_bioavail_frac_offset !< offset for iron bioavailability fraction + real :: atm_fe_to_bc_ratio !< atmospheric iron to black carbon ratio + real :: atm_bc_fe_bioavail_frac !< atmospheric black carbon to iron bioavailablity fraction ratio + real :: seaice_fe_to_bc_ratio !< sea-ice iron to black carbon ratio + real :: seaice_bc_fe_bioavail_frac !< sea-ice black carbon to iron bioavailablity fraction ratio + real :: iron_frac_in_atm_fine_dust !< Fraction of fine dust from the atmosphere that is iron + real :: iron_frac_in_atm_coarse_dust !< Fraction of coarse dust from the atmosphere that is iron + real :: iron_frac_in_seaice_dust !< Fraction of dust from the sea ice that is iron + real :: atm_co2_const !< atmospheric CO2 (if specifying a constant value) [ppm] + real :: atm_alt_co2_const !< alternate atmospheric CO2 for _ALT_CO2 tracers + !! (if specifying a constant value) [ppm] + + type(marbl_forcing_diag_ids) :: diag_ids !< used for registering and posting some MARBL forcing fields as diagnostics + + logical :: use_marbl_tracers !< most functions can return immediately + !! MARBL tracers are turned off + integer :: atm_co2_iopt !< Integer version of atm_co2_opt, which determines source of atm_co2 + integer :: atm_alt_co2_iopt !< Integer version of atm_alt_co2_opt, which determines source of atm_alt_co2 + +end type marbl_forcing_CS + +! Module parameters +integer, parameter :: atm_co2_constant_iopt = 0 !< module parameter denoting atm_co2_opt = 'constant' +integer, parameter :: atm_co2_prognostic_iopt = 1 !< module parameter denoting atm_co2_opt = 'diagnostic' +integer, parameter :: atm_co2_diagnostic_iopt = 2 !< module parameter denoting atm_co2_opt = 'prognostic' + +contains + + subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_marbl, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + character(len=*), intent(in) :: inputdir !< Directory containing input files + logical, intent(in) :: use_marbl !< Is MARBL tracer package active? + type(marbl_forcing_CS), pointer, intent(inout) :: CS !< A pointer that is set to point to control + !! structure for MARBL forcing + + character(len=40) :: mdl = "MARBL_forcing_mod" ! This module's name. + character(len=15) :: atm_co2_opt + character(len=200) :: err_message + + if (associated(CS)) then + call MOM_error(WARNING, "marbl_forcing_init called with an associated control structure.") + return + endif + + allocate(CS) + CS%diag => diag + + CS%use_marbl_tracers = .true. + if (.not. use_marbl) then + CS%use_marbl_tracers = .false. + return + endif + + call get_param(param_file, mdl, "DUST_RATIO_THRES", CS%dust_ratio_thres, & + "TODO: Add description", units="add_units", default=69.00594) + call get_param(param_file, mdl, "DUST_RATIO_TO_FE_BIOAVAIL_FRAC", & + CS%dust_ratio_to_fe_bioavail_frac, & + "TODO: Add description", units="add_units", default=1./366.314) + call get_param(param_file, mdl, "FE_BIOAVAIL_FRAC_OFFSET", CS%fe_bioavail_frac_offset, & + "TODO: Add description", units="add_units", default=0.0146756) + call get_param(param_file, mdl, "ATM_FE_TO_BC_RATIO", CS%atm_fe_to_bc_ratio, & + "TODO: Add description", units="add_units", default=1.) + call get_param(param_file, mdl, "ATM_BC_FE_BIOAVAIL_FRAC", CS%atm_bc_fe_bioavail_frac, & + "TODO: Add description", units="add_units", default=0.06) + call get_param(param_file, mdl, "SEAICE_FE_TO_BC_RATIO", CS%seaice_fe_to_bc_ratio, & + "TODO: Add description", units="add_units", default=1.) + call get_param(param_file, mdl, "SEAICE_BC_FE_BIOAVAIL_FRAC", CS%seaice_bc_fe_bioavail_frac, & + "TODO: Add description", units="add_units", default=0.06) + call get_param(param_file, mdl, "IRON_FRAC_IN_ATM_FINE_DUST", CS%iron_frac_in_atm_fine_dust, & + "Fraction of fine dust from the atmosphere that is iron", units="add_units", default=0.035) + call get_param(param_file, mdl, "IRON_FRAC_IN_ATM_COARSE_DUST", & + CS%iron_frac_in_atm_coarse_dust, & + "Fraction of coarse dust from the atmosphere that is iron", units="add_units", & + default=0.035) + call get_param(param_file, mdl, "IRON_FRAC_IN_SEAICE_DUST", CS%iron_frac_in_seaice_dust, & + "Fraction of dust from sea ice that is iron", units="add_units", default=0.035) + call get_param(param_file, mdl, "ATM_CO2_OPT", atm_co2_opt, & + "Source of atmospheric CO2 [constant, diagnostic, or prognostic]", & + default="constant") + select case (trim(atm_co2_opt)) + case("prognostic") + CS%atm_co2_iopt = atm_co2_prognostic_iopt + case("diagnostic") + CS%atm_co2_iopt = atm_co2_diagnostic_iopt + case("constant") + CS%atm_co2_iopt = atm_co2_constant_iopt + case DEFAULT + write(err_message, "(3A)") "'", trim(atm_co2_opt), "' is not a valid ATM_CO2_OPT value" + call MOM_error(FATAL, err_message) + end select + if (CS%atm_co2_iopt == atm_co2_constant_iopt) then + call get_param(param_file, mdl, "ATM_CO2_CONST", CS%atm_co2_const, & + "Value to send to MARBL as xco2", & + default=284.317, units="ppm") + endif + call get_param(param_file, mdl, "ATM_ALT_CO2_OPT", atm_co2_opt, & + "Source of alternate atmospheric CO2 [constant, diagnostic, or prognostic]", & + default="constant") + select case (trim(atm_co2_opt)) + case("prognostic") + CS%atm_alt_co2_iopt = atm_co2_prognostic_iopt + case("diagnostic") + CS%atm_alt_co2_iopt = atm_co2_diagnostic_iopt + case("constant") + CS%atm_alt_co2_iopt = atm_co2_constant_iopt + case DEFAULT + write(err_message, "(3A)") "'", trim(atm_co2_opt), "' is not a valid ATM_ALT_CO2_OPT value" + call MOM_error(FATAL, err_message) + end select + if (CS%atm_alt_co2_iopt == atm_co2_constant_iopt) then + call get_param(param_file, mdl, "ATM_ALT_CO2_CONST", CS%atm_alt_co2_const, & + "Value to send to MARBL as xco2_alt_co2", & + default=284.317, units="ppm") + endif + + ! Register diagnostic fields for outputing forcing values + ! These fields are posted from convert_driver_fields_to_forcings(), and they are received + ! in physical units so no conversion is necessary here. + CS%diag_ids%atm_fine_dust = register_diag_field("ocean_model", "ATM_FINE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_FINE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%atm_coarse_dust = register_diag_field("ocean_model", "ATM_COARSE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_COARSE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%atm_bc = register_diag_field("ocean_model", "ATM_BLACK_CARBON_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "ATM_BLACK_CARBON_FLUX from cpl", "kg/m^2/s") + + CS%diag_ids%ice_dust = register_diag_field("ocean_model", "SEAICE_DUST_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "SEAICE_DUST_FLUX from cpl", "kg/m^2/s") + CS%diag_ids%ice_bc = register_diag_field("ocean_model", "SEAICE_BLACK_CARBON_FLUX_CPL", & + CS%diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "SEAICE_BLACK_CARBON_FLUX from cpl", "kg/m^2/s") + + end subroutine MARBL_forcing_init + + ! Note: ice fraction and u10_sqr are handled in mom_surface_forcing because of CFCs + subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust_flux, & + seaice_dust_flux, atm_bc_flux, seaice_bc_flux, & + nhx_dep, noy_dep, atm_co2_prog, atm_co2_diag, & + afracr, swnet_afracr, ifrac_n, & + swpen_ifrac_n, Time, G, US, i0, j0, fluxes, CS) + + real, dimension(:,:), pointer, intent(in) :: atm_fine_dust_flux !< atmosphere fine dust flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_coarse_dust_flux !< atmosphere coarse dust flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: seaice_dust_flux !< sea ice dust flux from IOB [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_bc_flux !< atmosphere black carbon flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: seaice_bc_flux !< sea ice black carbon flux from IOB + !! [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: afracr !< open ocean fraction + real, dimension(:,:), pointer, intent(in) :: nhx_dep !< NHx flux from atmosphere [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: noy_dep !< NOy flux from atmosphere [kg m-2 s-1] + real, dimension(:,:), pointer, intent(in) :: atm_co2_prog !< Prognostic atmospheric CO2 concentration + real, dimension(:,:), pointer, intent(in) :: atm_co2_diag !< Diagnostic atmospheric CO2 concentration + real, dimension(:,:), pointer, intent(in) :: swnet_afracr !< shortwave flux * open ocean fraction + real, dimension(:,:,:), pointer, intent(in) :: ifrac_n !< per-category ice fraction + real, dimension(:,:,:), pointer, intent(in) :: swpen_ifrac_n !< per-category shortwave flux * ice fraction + type(time_type), intent(in) :: Time !< The time of the fluxes, used for + !! interpolating the salinity to the + !! right time, when it is being + !! restored. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: i0 !< i index offset + integer, intent(in) :: j0 !< j index offset + type(forcing), intent(inout) :: fluxes !< MARBL-specific forcing fields + type(marbl_forcing_CS), pointer, intent(inout) :: CS !< A pointer that is set to point to + !! control structure for MARBL forcing + + integer :: i, j, is, ie, js, je, m + real :: atm_fe_bioavail_frac !< TODO: define this (local) term + real :: seaice_fe_bioavail_frac !< TODO: define this (local) term + real :: iron_flux_conversion !< TODO: define this (local) term + real :: ndep_conversion !< Combination of unit conversion factors for rescaling + !! nitrogen deposition [kg(N) m-2 s-1 ~> mol m-3 Z T-1] + + if (.not. CS%use_marbl_tracers) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + ndep_conversion = (1.e6/14.) * (US%m_to_Z * US%T_to_s) ! kg / m^2 / s -> conc Z / T + iron_flux_conversion = (1.e6 / molw_Fe) * (US%m_to_Z * US%T_to_s) ! kg / m^2 / s -> conc Z / T + + ! Post fields from coupler to diagnostics + ! TODO: units from diag register are incorrect; we should be converting these in the cap, I think + if (CS%diag_ids%atm_fine_dust > 0) & + call post_data(CS%diag_ids%atm_fine_dust, atm_fine_dust_flux(is-i0:ie-i0,js-j0:je-j0), & + CS%diag, mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%atm_coarse_dust > 0) & + call post_data(CS%diag_ids%atm_coarse_dust, atm_coarse_dust_flux(is-i0:ie-i0,js-j0:je-j0), & + CS%diag, mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%atm_bc > 0) & + call post_data(CS%diag_ids%atm_bc, atm_bc_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%ice_dust > 0) & + call post_data(CS%diag_ids%ice_dust, seaice_dust_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + if (CS%diag_ids%ice_bc > 0) & + call post_data(CS%diag_ids%ice_bc, seaice_bc_flux(is-i0:ie-i0,js-j0:je-j0), CS%diag, & + mask=G%mask2dT(is:ie,js:je)) + + do j=js,je ; do i=is,ie + ! Nitrogen Deposition + fluxes%nhx_dep(i,j) = (G%mask2dT(i,j) * ndep_conversion) * nhx_dep(i-i0,j-j0) + fluxes%noy_dep(i,j) = (G%mask2dT(i,j) * ndep_conversion) * noy_dep(i-i0,j-j0) + enddo ; enddo + + ! Atmospheric CO2 + select case (CS%atm_co2_iopt) + case (atm_co2_prognostic_iopt) + if (associated(atm_co2_prog)) then + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * atm_co2_prog(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_CO2_OPT = 'prognostic' but atmosphere is not providing this field") + endif + case (atm_co2_diagnostic_iopt) + if (associated(atm_co2_diag)) then + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * atm_co2_diag(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_CO2_OPT = 'diagnostic' but atmosphere is not providing this field") + endif + case (atm_co2_constant_iopt) + do j=js,je ; do i=is,ie + fluxes%atm_co2(i,j) = G%mask2dT(i,j) * CS%atm_co2_const + enddo ; enddo + end select + + ! Alternate Atmospheric CO2 + select case (CS%atm_alt_co2_iopt) + case (atm_co2_prognostic_iopt) + if (associated(atm_co2_prog)) then + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * atm_co2_prog(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_ALT_CO2_OPT = 'prognostic' but atmosphere is not providing this field") + endif + case (atm_co2_diagnostic_iopt) + if (associated(atm_co2_diag)) then + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * atm_co2_diag(i-i0,j-j0) + enddo ; enddo + else + call MOM_error(FATAL, & + "ATM_ALT_CO2_OPT = 'diagnostic' but atmosphere is not providing this field") + endif + case (atm_co2_constant_iopt) + do j=js,je ; do i=is,ie + fluxes%atm_alt_co2(i,j) = G%mask2dT(i,j) * CS%atm_co2_const + enddo ; enddo + end select + + ! Dust flux + if (associated(atm_fine_dust_flux)) then + do j=js,je ; do i=is,ie + fluxes%dust_flux(i,j) = US%kg_m2s_to_RZ_T * G%mask2dT(i,j) * & + (atm_fine_dust_flux(i-i0,j-j0) + atm_coarse_dust_flux(i-i0,j-j0) + & + seaice_dust_flux(i-i0,j-j0)) + enddo ; enddo + endif + + if (associated(atm_bc_flux)) then + do j=js,je ; do i=is,ie + ! TODO: abort if atm_fine_dust_flux and atm_coarse_dust_flux are not associated? + ! Contribution of atmospheric dust to iron flux + if (atm_coarse_dust_flux(i-i0,j-j0) < & + CS%dust_ratio_thres * atm_fine_dust_flux(i-i0,j-j0)) then + atm_fe_bioavail_frac = CS%fe_bioavail_frac_offset + CS%dust_ratio_to_fe_bioavail_frac * & + (CS%dust_ratio_thres - atm_coarse_dust_flux(i-i0,j-j0) / atm_fine_dust_flux(i-i0,j-j0)) + else + atm_fe_bioavail_frac = CS%fe_bioavail_frac_offset + endif + + ! Contribution of atmospheric dust to iron flux + fluxes%iron_flux(i,j) = (atm_fe_bioavail_frac * & + (CS%iron_frac_in_atm_fine_dust * atm_fine_dust_flux(i-i0,j-j0) + & + CS%iron_frac_in_atm_coarse_dust * atm_coarse_dust_flux(i-i0,j-j0))) + + ! Contribution of atmospheric black carbon to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (CS%atm_bc_fe_bioavail_frac * & + (CS%atm_fe_to_bc_ratio * atm_bc_flux(i-i0,j-j0))) + + seaice_fe_bioavail_frac = atm_fe_bioavail_frac + ! Contribution of seaice dust to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (seaice_fe_bioavail_frac * & + (CS%iron_frac_in_seaice_dust * seaice_dust_flux(i-i0,j-j0))) + + ! Contribution of seaice black carbon to iron flux + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (CS%seaice_bc_fe_bioavail_frac * & + (CS%seaice_fe_to_bc_ratio * seaice_bc_flux(i-i0,j-j0))) + + ! Unit conversion (kg / m^2 / s -> conc Z/T) + fluxes%iron_flux(i,j) = (G%mask2dT(i,j) * iron_flux_conversion) * fluxes%iron_flux(i,j) + + enddo ; enddo + endif + + ! Per ice-category forcings + ! If the cap receives per-category fields, memory should be allocated in fluxes + if (associated(ifrac_n)) then + do j=js,je ; do i=is,ie + fluxes%fracr_cat(i,j,1) = min(1., afracr(i-i0,j-j0)) + fluxes%qsw_cat(i,j,1) = swnet_afracr(i-i0,j-j0) + do m=1,size(ifrac_n, 3) + fluxes%fracr_cat(i,j,m+1) = min(1., ifrac_n(i-i0,j-j0,m)) + fluxes%qsw_cat(i,j,m+1) = swpen_ifrac_n(i-i0,j-j0,m) + enddo + where (fluxes%fracr_cat(i,j,:) > 0.) + fluxes%qsw_cat(i,j,:) = fluxes%qsw_cat(i,j,:) / fluxes%fracr_cat(i,j,:) + elsewhere + fluxes%fracr_cat(i,j,:) = 0. + fluxes%qsw_cat(i,j,:) = 0. + endwhere + fluxes%fracr_cat(i,j,:) = G%mask2dT(i,j) * fluxes%fracr_cat(i,j,:) + fluxes%qsw_cat(i,j,:) = G%mask2dT(i,j) * fluxes%qsw_cat(i,j,:) + enddo; enddo + endif + + end subroutine convert_driver_fields_to_forcings + +end module MARBL_forcing_mod diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 new file mode 100644 index 0000000000..9c856fef85 --- /dev/null +++ b/src/tracer/MARBL_tracers.F90 @@ -0,0 +1,2206 @@ +!> A tracer package for tracers computed in the MARBL library +!! +!! Currently configured for use with marbl0.36.0 +!! https://github.com/marbl-ecosys/MARBL/releases/tag/marbl0.36.0 +!! (clone entire repo into pkg/MARBL) +module MARBL_tracers + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_coms, only : EFP_type, root_PE, broadcast +use MOM_debugging, only : hchksum +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : is_root_PE, MOM_error, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_interpolate, only : external_field, init_external_field, time_interp_external +use MOM_CVMix_KPP, only : KPP_NonLocalTransport, KPP_CS +use MOM_hor_index, only : hor_index_type +use MOM_interpolate, only : forcing_timeseries_dataset +use MOM_interpolate, only : forcing_timeseries_set_time_type_vars +use MOM_interpolate, only : map_model_time_to_forcing_time +use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_remapping, only : reintegrate_column +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_restart, only : query_initialized, MOM_restart_CS, register_restart_field +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type +use MOM_tracer_registry, only : register_tracer +use MOM_tracer_types, only : tracer_type, tracer_registry_type +use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut +use MOM_tracer_initialization_from_Z, only : MOM_initialize_tracer_from_Z +use MOM_tracer_Z_init, only : read_Z_edges +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_diag_mediator, only : register_diag_field, post_data!, safe_alloc_ptr + +use MARBL_interface, only : MARBL_interface_class +use MARBL_interface_public_types, only : marbl_diagnostics_type, marbl_saved_state_type + +use coupler_types_mod, only : coupler_type_set_data, ind_csurf +use atmos_ocean_fluxes_mod, only : aof_set_coupler_flux + +implicit none ; private + +#include + +public register_MARBL_tracers, initialize_MARBL_tracers +public MARBL_tracers_column_physics, MARBL_tracers_surface_state +public MARBL_tracers_set_forcing +public MARBL_tracers_stock, MARBL_tracers_get, MARBL_tracers_end + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +!> Temporary type for diagnostic variables coming from MARBL +!! Allocate exactly one of field_[23]d +type :: temp_MARBL_diag + integer :: id !< index into MOM diagnostic structure + real, allocatable :: field_2d(:,:) !< memory for 2D field + real, allocatable :: field_3d(:,:,:) !< memory for 3D field +end type temp_MARBL_diag + +!> MOM6 needs to know the index of some MARBL tracers to properly apply river fluxes +type :: tracer_ind_type + integer :: no3_ind !< NO3 index + integer :: po4_ind !< PO4 index + integer :: don_ind !< DON index + integer :: donr_ind !< DONr index + integer :: dop_ind !< DOP index + integer :: dopr_ind !< DOPr index + integer :: sio3_ind !< SiO3 index + integer :: fe_ind !< Fe index + integer :: doc_ind !< DOC index + integer :: docr_ind !< DOCr index + integer :: alk_ind !< ALK index + integer :: alk_alt_co2_ind !< ALK_ALT_CO2 index + integer :: dic_ind !< DIC index + integer :: dic_alt_co2_ind !< DIC_ALT_CO2 index +end type tracer_ind_type + +!> MOM needs to store some information about saved_state; besides providing these +!! fields to MARBL, they are also written to restart files +type :: saved_state_for_MARBL_type + character(len=200) :: short_name !< name of variable being saved + character(len=200) :: file_varname !< name of variable in restart file + character(len=200) :: units !< variable units + real, pointer :: field_2d(:,:) !< memory for 2D field + real, pointer :: field_3d(:,:,:) !< memory for 3D field +end type saved_state_for_MARBL_type + +!> All calls to MARBL are done via the interface class +type(MARBL_interface_class) :: MARBL_instances + +!> Pointer to tracer concentration and to tracer_type in tracer registry +type, private :: MARBL_tracer_data + real, pointer :: tr(:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + type(tracer_type), pointer :: tr_ptr => NULL() !< pointer to tracer inside Tr_reg +end type MARBL_tracer_data + +!> The control structure for the MARBL tracer package +type, public :: MARBL_tracers_CS ; private + integer :: ntr !< The number of tracers that are actually used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: base_bio_on !< Will MARBL use base biotic tracers? + logical :: abio_dic_on !< Will MARBL use abiotic DIC / DI14C tracers? + logical :: ciso_on !< Will MARBL use isotopic tracers? + + integer :: restore_count !< The number of tracers MARBL is configured to restore + logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. + logical :: use_ice_category_fields !< Forcing will include multiple ice categories for ice_frac and shortwave + logical :: request_Chl_from_MARBL !< MARBL can provide Chl to use in set_pen_shortwave() + integer :: ice_ncat !< Number of ice categories when use_ice_category_fields = True + real :: IC_min !< Minimum value for tracer initial conditions + character(len=200) :: IC_file !< The file in which the age-tracer initial values cam be found. + logical :: ongrid !< True if IC_file is already interpolated to MOM grid + type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry + type(MARBL_tracer_data), dimension(:), allocatable :: tracer_data !< type containing tracer data and pointer + !! into tracer registry + + integer, allocatable, dimension(:) :: ind_tr !< Indices returned by aof_set_coupler_flux if it is used and the + !! surface tracer concentrations are to be provided to the coupler. + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. + type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart control structure + + type(vardesc), allocatable :: tr_desc(:) !< Descriptions and metadata for the tracers + logical :: tracers_may_reinit !< If true the tracers may be initialized if not found in a restart file + + character(len=200) :: fesedflux_file !< name of [netCDF] file containing iron sediment flux + character(len=200) :: feventflux_file !< name of [netCDF] file containing iron vent flux + type(forcing_timeseries_dataset) :: d14c_dataset(3) !< File and time axis information for d14c forcing + real, dimension(3) :: d14c_bands !< forcing is organized into bands: [30 N, 90 N]; [30 S, 30 N]; [90 S, 30 S] + integer :: d14c_id !< id for diagnostic field with d14c forcing + logical :: read_riv_fluxes !< If true, use river fluxes supplied from an input file. + !! This is temporary, we will always read river fluxes + type(forcing_timeseries_dataset) :: riv_flux_dataset !< File and time axis information for river fluxes + character(len=4) :: restoring_source !< location of tracer restoring data + !! valid values: file, none + integer :: restoring_nz !< number of levels in tracer restoring file + real, allocatable, dimension(:) :: & + restoring_z_edges !< The depths of the cell interfaces in the tracer restoring file [Z ~> m] + real, allocatable, dimension(:) :: & + restoring_dz !< The thickness of the cell layers in the tracer restoring file [H ~> m] + integer :: restoring_timescale_nz !< number of levels in tracer restoring timescale file + real, allocatable, dimension(:) :: & + restoring_timescale_z_edges !< The depths of the cell interfaces in the tracer restoring timescale file [Z ~> m] + real, allocatable, dimension(:) :: & + restoring_timescale_dz !< The thickness of the cell layers in the tracer restoring timescale file [H ~> m] + character(len=14) :: restoring_I_tau_source !< location of inverse restoring timescale data + !! valid values: file, grid_dependent + character(len=200) :: restoring_file !< name of [netCDF] file containing tracer restoring data + type(remapping_CS) :: restoring_remapCS !< Remapping parameters and work arrays for tracer restoring / timescale + character(len=200) :: restoring_I_tau_file !< name of [netCDF] file containing inverse restoring timescale + character(len=200) :: restoring_I_tau_var_name !< name of field containing inverse restoring timescale + character(len=35) :: marbl_settings_file !< name of [text] file containing MARBL settings + + real :: bot_flux_mix_thickness !< for bottom flux -> tendency conversion, assume uniform mixing over + !! bottom layer of prescribed thickness [Z ~> m] + real :: Ibfmt !< Reciprocal of bot_flux_mix_thickness [Z-1 ~> m-1] + + type(temp_MARBL_diag), allocatable :: surface_flux_diags(:) !< collect surface flux diagnostics from all columns + !! before posting + type(temp_MARBL_diag), allocatable :: interior_tendency_diags(:) !< collect tendency diagnostics from all columns + !! before posting + type(saved_state_for_MARBL_type), allocatable :: surface_flux_saved_state(:) !< surface_flux saved state + type(saved_state_for_MARBL_type), allocatable :: interior_tendency_saved_state(:) !< interior_tendency saved state + + ! TODO: If we can post data column by column, all we need are integer arrays for ids + ! integer, allocatable :: id_surface_flux_diags(:) !< array of indices for surface_flux diagnostics + ! integer, allocatable :: id_interior_tendency_diags(:) !< array of indices for interior_tendency diagnostics + + type(tracer_ind_type) :: tracer_inds !< Indices to tracers that will have river fluxes added to STF + + !> Need to store global output from both marbl_instance%surface_flux_compute() and + !! marbl_instance%interior_tendency_compute(). For the former, just need id to register + !! because we already copy data into CS%STF; latter requires copying data and indices + !! so currently using temp_MARBL_diag for that. + integer, allocatable :: id_surface_flux_out(:) !< register_diag indices for surface_flux output + type(temp_MARBL_diag), allocatable :: interior_tendency_out(:) !< collect interior tendencies for diagnostic output + type(temp_MARBL_diag), allocatable :: interior_tendency_out_zint(:) !< vertical integral of interior tendencies + !! (full column) + type(temp_MARBL_diag), allocatable :: interior_tendency_out_zint_100m(:) !< vertical integral of interior tendencies + !! (top 100m) + integer :: bot_flux_to_tend_id !< register_diag index for BOT_FLUX_TO_TEND + integer, allocatable :: fracr_cat_id(:) !< register_diag index for per-category ice fraction + integer, allocatable :: qsw_cat_id(:) !< register_diag index for per-category shortwave + + real, allocatable :: STF(:,:,:) !< surface fluxes returned from MARBL to use in tracer_vertdiff + !! (dims: i, j, tracer) [conc Z T-1 ~> conc m s-1] + real, allocatable :: SFO(:,:,:) !< surface flux output returned from MARBL for use in GCM + !! e.g. CO2 flux to pass to atmosphere (dims: i, j, num_sfo) + real, allocatable :: ITO(:,:,:,:) !< interior tendency output returned from MARBL for use in GCM + !! e.g. total chlorophyll to use in shortwave penetration (dims: i, j, k, num_ito) + + integer :: u10_sqr_ind !< index of MARBL forcing field array to copy 10-m wind (squared) into + integer :: sss_ind !< index of MARBL forcing field array to copy sea surface salinity into + integer :: sst_ind !< index of MARBL forcing field array to copy sea surface temperature into + integer :: ifrac_ind !< index of MARBL forcing field array to copy ice fraction into + integer :: dust_dep_ind !< index of MARBL forcing field array to copy dust flux into + integer :: fe_dep_ind !< index of MARBL forcing field array to copy iron flux into + integer :: nox_flux_ind !< index of MARBL forcing field array to copy NOx flux into + integer :: nhy_flux_ind !< index of MARBL forcing field array to copy NHy flux into + integer :: atmpress_ind !< index of MARBL forcing field array to copy atmospheric pressure into + integer :: xco2_ind !< index of MARBL forcing field array to copy CO2 flux into + integer :: xco2_alt_ind !< index of MARBL forcing field array to copy CO2 flux (alternate CO2) into + integer :: d14c_ind !< index of MARBL forcing field array to copy d14C into + + !> external_field types for river fluxes (added to surface fluxes) + type(external_field) :: id_din_riv !< id for time_interp_external. + type(external_field) :: id_don_riv !< id for time_interp_external. + type(external_field) :: id_dip_riv !< id for time_interp_external. + type(external_field) :: id_dop_riv !< id for time_interp_external. + type(external_field) :: id_dsi_riv !< id for time_interp_external. + type(external_field) :: id_dfe_riv !< id for time_interp_external. + type(external_field) :: id_dic_riv !< id for time_interp_external. + type(external_field) :: id_alk_riv !< id for time_interp_external. + type(external_field) :: id_doc_riv !< id for time_interp_external. + + !> external_field type for d14c (needed if abio_dic_on is True) + type(external_field) :: id_d14c(3) !< id for time_interp_external. + + !> Indices for river fluxes (diagnostics) + integer :: no3_riv_flux !< NO3 riverine flux + integer :: po4_riv_flux !< PO4 riverine flux + integer :: don_riv_flux !< DON riverine flux + integer :: donr_riv_flux !< DONr riverine flux + integer :: dop_riv_flux !< DOP riverine flux + integer :: dopr_riv_flux !< DOPr riverine flux + integer :: sio3_riv_flux !< SiO3 riverine flux + integer :: fe_riv_flux !< Fe riverine flux + integer :: doc_riv_flux !< DOC riverine flux + integer :: docr_riv_flux !< DOCr riverine flux + integer :: alk_riv_flux !< ALK riverine flux + integer :: alk_alt_co2_riv_flux !< ALK (alternate CO2) riverine flux + integer :: dic_riv_flux !< DIC riverine flux + integer :: dic_alt_co2_riv_flux !< DIC (alternate CO2) riverine flux + + !> Indices for forcing fields required to compute interior tendencies + integer :: dustflux_ind !< index of MARBL forcing field array to copy dust flux into + integer :: PAR_col_frac_ind !< index of MARBL forcing field array to copy PAR column fraction into + integer :: surf_shortwave_ind !< index of MARBL forcing field array to copy surface shortwave into + integer :: potemp_ind !< index of MARBL forcing field array to copy potential temperature into + integer :: salinity_ind !< index of MARBL forcing field array to copy salinity into + integer :: pressure_ind !< index of MARBL forcing field array to copy pressure into + integer :: fesedflux_ind !< index of MARBL forcing field array to copy iron sediment flux into + integer :: o2_scalef_ind !< index of MARBL forcing field array to copy O2 scale length into + integer :: remin_scalef_ind !< index of MARBL forcing field array to copy remin scale length into + type(external_field), allocatable :: id_tracer_restoring(:) !< id number for time_interp_external + integer, allocatable :: tracer_restoring_ind(:) !< index of MARBL forcing field to copy + !! per-tracer restoring field into + integer, allocatable :: tracer_I_tau_ind(:) !< index of MARBL forcing field to copy per-tracer + !! inverse restoring timescale into + + !> Memory for storing river fluxes, tracer restoring fields, and abiotic forcing + real, allocatable :: d14c(:,:) !< d14c forcing for abiotic DIC and carbon isotope tracer modules + real, allocatable :: RIV_FLUXES(:,:,:) !< river flux forcing for applyTracerBoundaryFluxesInOut + !! (needs to be time-integrated when passed to function!) + !! (dims: i, j, tracer) [conc m s-1] + character(len=15), allocatable :: tracer_restoring_varname(:) !< name of variable being restored + real, allocatable :: I_tau(:,:,:) !< inverse restoring timescale for marbl tracers (dims: i, j, k) [1/s] + real, allocatable, dimension(:,:,:,:) :: restoring_in !< Restoring fields read from file + !! (dims: i, j, restoring_nz, restoring_cnt) [tracer units] + + !> Number of surface flux outputs as well as specific indices for each one + integer :: sfo_cnt !< number of surface flux outputs from MARBL + integer :: ito_cnt !< number of interior tendency outputs from MARBL + integer :: flux_co2_ind !< index to co2 flux surface flux output + integer :: total_Chl_ind !< index to total chlorophyll interior tendency output + + ! TODO: create generic 3D forcing input type to read z coordinate + values + real :: fesedflux_scale_factor !< scale factor for iron sediment flux + integer :: fesedflux_nz !< number of levels in iron sediment flux file + real, allocatable, dimension(:,:,:) :: fesedflux_in !< Field to read iron sediment flux into [conc m s-1] + real, allocatable, dimension(:,:,:) :: feventflux_in !< Field to read iron vent flux into [conc m s-1] + real, allocatable, dimension(:) :: & + fesedflux_z_edges !< The depths of the cell interfaces in the input data [Z ~> m] + ! TODO: this thickness does not need to be 3D, but that's a problem for future Mike + real, allocatable, dimension(:,:,:) :: & + fesedflux_dz !< The thickness of the cell layers in the input data [H ~> m] +end type MARBL_tracers_CS + +! Module parameters +real, parameter :: atm_per_Pa = 1./101325. !< convert from Pa -> atm + +contains + +!> This subroutine is used to read marbl_in, configure MARBL accordingly, and then +!! call MARBL's initialization routine +subroutine configure_MARBL_tracers(GV, US, param_file, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MARBL_tracers_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + +# include "version_variable.h" + character(len=40) :: mdl = "MARBL_tracers" ! This module's name. + character(len=256) :: log_message + character(len=256) :: marbl_in_line(1) + character(len=256) :: forcing_sname, field_source + integer :: m, n, nz, marbl_settings_in, read_error, I_tau_count, fi + logical :: chl_from_file, forcing_processed + nz = GV%ke + marbl_settings_in = 615 + + ! (1) Read parameters necessary for general setup of MARBL + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "MARBL_IC_MIN_VAL", CS%IC_min, & + "Minimum value of tracer initial conditions (set to 1e-100 for dim scaling tests)", & + default=0., units="tracer units") + call get_param(param_file, mdl, "MARBL_SETTINGS_FILE", CS%marbl_settings_file, & + "The name of a file from which to read the run-time settings for MARBL.", default="marbl_in") + call get_param(param_file, mdl, "BOT_FLUX_MIX_THICKNESS", CS%bot_flux_mix_thickness, & + "Bottom fluxes are uniformly mixed over layer of this thickness", default=1., units="m", & + scale=US%m_to_Z) + call get_param(param_file, mdl, "USE_ICE_CATEGORIES", CS%use_ice_category_fields, & + "If true, allocate memory for shortwave and ice fraction split by ice thickness category.", & + default=.false.) + call get_param(param_file, mdl, "ICE_NCAT", CS%ice_ncat, & + "Number of ice thickness categories in shortwave and ice fraction forcings.", default=0) + CS%Ibfmt = 1. / CS%bot_flux_mix_thickness + + if (CS%use_ice_category_fields .and. (CS%ice_ncat == 0)) & + call MOM_error(FATAL, & + "Can not configure MARBL to use multiple ice categories without ice_ncat present") + + ! (2) Read marbl settings file and call put_setting() + ! (2a) only master task opens file + if (is_root_PE()) then + ! read the marbl_in into buffer + open(unit=marbl_settings_in, file=CS%marbl_settings_file, iostat=read_error) + if (read_error .ne. 0) then + write(log_message, '(A, I0, 2A)') "IO ERROR ", read_error, " opening namelist file : ", & + trim(CS%marbl_settings_file) + call MOM_error(FATAL, log_message) + endif + endif + + ! (2b) master task reads file and broadcasts line-by-line + marbl_in_line = '' + do + ! i. Read next line on master, iostat value out + ! (Exit loop if read is not successful; either read error or end of file) + if (is_root_PE()) read(marbl_settings_in, "(A)", iostat=read_error) marbl_in_line(1) + call broadcast(read_error, root_PE()) + if (read_error .ne. 0) exit + + ! ii. Broadcast line just read in on root PE to all tasks + call broadcast(marbl_in_line, 256, root_PE()) + + ! iii. All tasks call put_setting (TODO: openMP blocks?) + call MARBL_instances%put_setting(marbl_in_line(1)) + enddo + + ! (2c) we should always reach the EOF to capture the entire file... + if (.not. is_iostat_end(read_error)) then + write(log_message, '(3A, I0)') "IO ERROR reading ", trim(CS%marbl_settings_file), ": ", & + read_error + call MOM_error(FATAL, log_message) + else + if (is_root_PE()) then + write(log_message, '(3A)') "Read '", trim(CS%marbl_settings_file), "' until EOF." + call MOM_error(NOTE, log_message) + endif + endif + if (is_root_PE()) close(marbl_settings_in) + + ! (3) Initialize MARBL and configure MOM6 accordingly + + ! (3a) call marbl%init() + ! TODO: We want to strip gcm_delta_z, gcm_zw, and gcm_zt values out of + ! init because MOM updates them every time step / every column + call MARBL_instances%init(gcm_num_levels = nz, gcm_num_PAR_subcols = CS%ice_ncat + 1, & + gcm_num_elements_surface_flux = 1, & ! FIXME: change to number of grid cells on MPI task + gcm_delta_z = GV%sInterface(2:nz+1) - GV%sInterface(1:nz), gcm_zw = GV%sInterface(2:nz+1), & + gcm_zt = GV%sLayer, unit_system_opt = "mks", lgcm_has_global_ops = .false.) ! FIXME: add global ops + ! Regardless of vertical grid, MOM6 will always use GV%ke levels in all columns + MARBL_instances%domain%kmt = GV%ke + if (MARBL_instances%StatusLog%labort_marbl) & + call MARBL_instances%StatusLog%log_error_trace("MARBL_instances%init", & + "configure_MARBL_tracers") + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + CS%ntr = size(MARBL_instances%tracer_metadata) + call marbl_instances%get_setting('base_bio_on', CS%base_bio_on) + call marbl_instances%get_setting('abio_dic_on', CS%abio_dic_on) + call marbl_instances%get_setting('ciso_on', CS%ciso_on) + + ! (3b) Read parameters that depend on how MARBL is configured + if (CS%base_bio_on) then + call get_param(param_file, mdl, "CHL_FROM_FILE", chl_from_file, & + "If true, chl_a is read from a file.", default=.true.) + CS%request_Chl_from_MARBL = (.not. chl_from_file) + else + CS%request_Chl_from_MARBL = .false. + endif + + ! (4) Request fields needed by MOM6 + CS%sfo_cnt = 0 + CS%ito_cnt = 0 + + if (CS%base_bio_on) then + ! CO2 Flux to the atmosphere + call MARBL_instances%add_output_for_GCM(num_elements=1, field_name="flux_co2", & + output_id=CS%flux_co2_ind, field_source=field_source) + if (trim(field_source) == "surface_flux") then + CS%sfo_cnt = CS%sfo_cnt + 1 + else if (trim(field_source) == "interior_tendency") then + CS%ito_cnt = CS%ito_cnt + 1 + end if + + ! Total 3D Chlorophyll + call MARBL_instances%add_output_for_GCM(num_elements=1, num_levels=nz, field_name="total_Chl", & + output_id=CS%total_Chl_ind, field_source=field_source) + if (trim(field_source) == "surface_flux") then + CS%sfo_cnt = CS%sfo_cnt + 1 + else if (trim(field_source) == "interior_tendency") then + CS%ito_cnt = CS%ito_cnt + 1 + end if + end if + + ! (5) Initialize forcing fields + ! i. store all surface forcing indices + CS%u10_sqr_ind = -1 + CS%sss_ind = -1 + CS%sst_ind = -1 + CS%ifrac_ind = -1 + CS%dust_dep_ind = -1 + CS%fe_dep_ind = -1 + CS%nox_flux_ind = -1 + CS%nhy_flux_ind = -1 + CS%atmpress_ind = -1 + CS%xco2_ind = -1 + CS%xco2_alt_ind = -1 + do m=1,size(MARBL_instances%surface_flux_forcings) + select case (trim(MARBL_instances%surface_flux_forcings(m)%metadata%varname)) + case('u10_sqr') + CS%u10_sqr_ind = m + case('sss') + CS%sss_ind = m + case('sst') + CS%sst_ind = m + case('Ice Fraction') + CS%ifrac_ind = m + case('Dust Flux') + CS%dust_dep_ind = m + case('Iron Flux') + CS%fe_dep_ind = m + case('NOx Flux') + CS%nox_flux_ind = m + case('NHy Flux') + CS%nhy_flux_ind = m + case('Atmospheric Pressure') + CS%atmpress_ind = m + case('xco2') + CS%xco2_ind = m + case('xco2_alt_co2') + CS%xco2_alt_ind = m + case('d14c') + CS%d14c_ind = m + case DEFAULT + write(log_message, "(A,1X,A)") & + trim(MARBL_instances%surface_flux_forcings(m)%metadata%varname), & + 'is not a valid surface flux forcing field name.' + call MOM_error(FATAL, log_message) + end select + enddo + + ! ii. store all interior forcing indices + CS%dustflux_ind = -1 + CS%PAR_col_frac_ind = -1 + CS%surf_shortwave_ind = -1 + CS%potemp_ind = -1 + CS%salinity_ind = -1 + CS%pressure_ind = -1 + CS%fesedflux_ind = -1 + CS%o2_scalef_ind = -1 + CS%remin_scalef_ind = -1 + CS%d14c_ind = -1 + allocate(CS%id_tracer_restoring(CS%ntr)) + allocate(CS%tracer_restoring_varname(CS%ntr), source=' ') ! gfortran 13.2 bug? + ! source = '' does not blank out strings + allocate(CS%tracer_restoring_ind(CS%ntr), source=-1) + allocate(CS%tracer_I_tau_ind(CS%ntr), source=-1) + CS%restore_count = 0 + I_tau_count = 0 + do m=1,size(MARBL_instances%interior_tendency_forcings) + select case (trim(MARBL_instances%interior_tendency_forcings(m)%metadata%varname)) + case('Dust Flux') + CS%dustflux_ind = m + case('PAR Column Fraction') + CS%PAR_col_frac_ind = m + case('Surface Shortwave') + CS%surf_shortwave_ind = m + case('Potential Temperature') + CS%potemp_ind = m + case('Salinity') + CS%salinity_ind = m + case('Pressure') + CS%pressure_ind = m + case('Iron Sediment Flux') + CS%fesedflux_ind = m + case('O2 Consumption Scale Factor') + CS%o2_scalef_ind = m + case('Particulate Remin Scale Factor') + CS%remin_scalef_ind = m + case DEFAULT + ! fi stands for forcing_index + fi = index(MARBL_instances%interior_tendency_forcings(m)%metadata%varname, & + 'Restoring Field') + if (fi > 0) then + CS%restore_count = CS%restore_count + 1 + CS%tracer_restoring_ind(CS%restore_count) = m + CS%tracer_restoring_varname(CS%restore_count) = & + MARBL_instances%interior_tendency_forcings(m)%metadata%varname(1:fi-2) + else + fi = index(MARBL_instances%interior_tendency_forcings(m)%metadata%varname, & + 'Restoring Inverse Timescale') + if (fi > 0) then + I_tau_count = I_tau_count + 1 + CS%tracer_I_tau_ind(I_tau_count) = m + else + write(log_message, "(A,1X,A)") & + trim(MARBL_instances%interior_tendency_forcings(m)%metadata%varname), & + 'is not a valid interior tendency forcing field name.' + call MOM_error(FATAL, log_message) + endif + endif + end select + enddo +end subroutine configure_MARBL_tracers + +!> This subroutine is used to register tracer fields and subroutines +!! to be used with MOM. +function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, MARBL_computes_chl) + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MARBL_tracers_CS), pointer :: CS !< A pointer that is set to point to the control + !! structure for this module + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control + !! structure for the tracer advection and diffusion module. + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + logical, intent(out) :: MARBL_computes_chl !< If MARBL is computing chlorophyll, MOM + !! may use it to compute SW penetration + +! Local variables +! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "MARBL_tracers" ! This module's name. + character(len=256) :: log_message + character(len=200) :: inputdir ! The directory where the input files are. + character(len=48) :: var_name ! The variable's name. + character(len=128) :: desc_name ! The variable's descriptor. + character(len=48) :: units ! The variable's units. + character(len=96) :: file_name ! file name for d14c (looped over three bands) + real, pointer :: tr_ptr(:,:,:) => NULL() + integer :: forcing_file_start_year + integer :: forcing_file_end_year + integer :: forcing_file_data_ref_year + integer :: forcing_file_model_ref_year + integer :: forcing_file_forcing_year + logical :: register_MARBL_tracers + logical :: restoring_has_edges, restoring_use_missing + logical :: restoring_timescale_has_edges, restoring_timescale_use_missing + real :: restoring_missing, restoring_timescale_missing + integer :: isd, ied, jsd, jed, nz, m, k, kbot + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + + if (associated(CS)) then + call MOM_error(WARNING, "register_MARBL_tracers called with an associated control structure.") + return + endif + allocate(CS) + + call configure_MARBL_tracers(GV, US, param_file, CS) + MARBL_computes_chl = CS%base_bio_on + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + ! ** Input directory + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + ! ** Tracer initial conditions + call get_param(param_file, mdl, "MARBL_TRACERS_IC_FILE", CS%IC_file, & + "The file in which the MARBL tracers initial values can be found.", & + default="ecosys_jan_IC_omip_latlon_1x1_180W_c230331.nc") + if (scan(CS%IC_file,'/') == 0) then + ! Add the directory if CS%IC_file is not already a complete path. + CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_IC_FILE", CS%IC_file) + endif + call get_param(param_file, mdl, "MARBL_TRACERS_MAY_REINIT", CS%tracers_may_reinit, & + "If true, tracers may go through the initialization code if they are not found in the "//& + "restart files. Otherwise it is a fatal error if tracers are not found in the "//& + "restart files of a restarted run.", default=.false.) + call get_param(param_file, mdl, "MARBL_TRACERS_INIT_VERTICAL_REMAP_ONLY", CS%ongrid, & + "If true, initial conditions are on the model horizontal grid. Extrapolation over " //& + "missing ocean values is done using an ICE-9 procedure with vertical ALE remapping .", & + default=.false.) + if (CS%base_bio_on) then + ! ** FESEDFLUX + call get_param(param_file, mdl, "MARBL_FESEDFLUX_FILE", CS%fesedflux_file, & + "The file in which the iron sediment flux forcing field can be found.", & + default="fesedflux_total_reduce_oxic_tx0.66v1.c230817.nc") + if (scan(CS%fesedflux_file,'/') == 0) then + ! Add the directory if CS%fesedflux_file is not already a complete path. + CS%fesedflux_file = trim(slasher(inputdir))//trim(CS%fesedflux_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_FESEDFLUX_FILE", CS%fesedflux_file) + endif + ! ** FEVENTFLUX + call get_param(param_file, mdl, "MARBL_FEVENTFLUX_FILE", CS%feventflux_file, & + "The file in which the iron vent flux forcing field can be found.", & + default="feventflux_5gmol_tx0.66v1.c230817.nc") + if (scan(CS%feventflux_file,'/') == 0) then + ! Add the directory if CS%feventflux_file is not already a complete path. + CS%feventflux_file = trim(slasher(inputdir))//trim(CS%feventflux_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_FEVENTFLUX_FILE", CS%feventflux_file) + endif + ! ** Scale factor for FESEDFLUX + call get_param(param_file, mdl, "MARBL_FESEDFLUX_SCALE_FACTOR", CS%fesedflux_scale_factor, & + "Conversion factor between FESEDFLUX file units and MARBL units", & + units="umol m-1 d-1 -> mmol m-2 s-1", default=0.001/86400.) + + ! ** River fluxes + call get_param(param_file, mdl, "READ_RIV_FLUXES", CS%read_riv_fluxes, & + "If true, use river fluxes supplied from an input file", default=.true.) + if (CS%read_riv_fluxes) then + call get_param(param_file, mdl, "RIV_FLUX_FILE", CS%riv_flux_dataset%file_name, & + "The file in which the river fluxes can be found", & + default="riv_nut.gnews_gnm.JRA025m_to_tx0.66v1_nnsm_e333r100_190910.20210405.nc") + ! call get_param(param_file, mdl, "RIV_FLUX_OFFSET_YEAR", CS%riv) + if (scan(CS%riv_flux_dataset%file_name,'/') == 0) then + ! CS%riv_flux_dataset%file_name = trim(inputdir) // trim(CS%riv_flux_dataset%file_name) + CS%riv_flux_dataset%file_name = trim(slasher(inputdir)) //& + trim(CS%riv_flux_dataset%file_name) + call log_param(param_file, mdl, "INPUTDIR/RIV_FLUX_FILE", CS%riv_flux_dataset%file_name) + endif + call get_param(param_file, mdl, "RIV_FLUX_L_TIME_VARYING", & + CS%riv_flux_dataset%l_time_varying, & + ".true. for time-varying forcing, .false. for static forcing", default=.false.) + if (CS%riv_flux_dataset%l_time_varying) then + call get_param(param_file, mdl, "RIV_FLUX_FILE_START_YEAR", forcing_file_start_year, & + "First year of data to read in RIV_FLUX_FILE", default=1900) + call get_param(param_file, mdl, "RIV_FLUX_FILE_END_YEAR", forcing_file_end_year, & + "Last year of data to read in RIV_FLUX_FILE", default=2000) + call get_param(param_file, mdl, "RIV_FLUX_FILE_DATA_REF_YEAR", forcing_file_data_ref_year, & + "Align this year in RIV_FLUX_FILE with RIV_FLUX_FILE_MODEL_REF_YEAR in model", & + default=1900) + call get_param(param_file, mdl, "RIV_FLUX_FILE_MODEL_REF_YEAR", & + forcing_file_model_ref_year, & + "Align this year in model with RIV_FLUX_FILE_DATA_REF_YEAR in RIV_FLUX_FILE", & + default=1) + else + call get_param(param_file, mdl, "RIV_FLUX_FORCING_YEAR", forcing_file_forcing_year, & + "Year from RIV_FLUX_FILE to use for forcing", default=1900) + endif + call forcing_timeseries_set_time_type_vars(forcing_file_start_year, forcing_file_end_year, & + forcing_file_data_ref_year, forcing_file_model_ref_year, forcing_file_forcing_year, & + CS%riv_flux_dataset) + endif + endif + + if (CS%abio_dic_on) then + call get_param(param_file, mdl, "D14C_L_TIME_VARYING", CS%d14c_dataset(1)%l_time_varying, & + ".true. for time-varying forcing, .false. for static forcing", default=.false.) + CS%d14c_dataset(2)%l_time_varying = CS%d14c_dataset(1)%l_time_varying + CS%d14c_dataset(3)%l_time_varying = CS%d14c_dataset(1)%l_time_varying + if (CS%d14c_dataset(1)%l_time_varying) then + call get_param(param_file, mdl, "D14C_FILE_START_YEAR", forcing_file_start_year, & + "First year of data to read in D14C_FILE", default=1850) + call get_param(param_file, mdl, "D14C_FILE_END_YEAR", forcing_file_end_year, & + "Last year of data to read in D14C_FILE", default=2015) + call get_param(param_file, mdl, "D14C_FILE_DATA_REF_YEAR", forcing_file_data_ref_year, & + "Align this year in D14C_FILE with D14C_FILE_MODEL_REF_YEAR in model", default=1850) + call get_param(param_file, mdl, "D14C_FILE_MODEL_REF_YEAR", forcing_file_model_ref_year, & + "Align this year in model with D14C_FILE_DATA_REF_YEAR in D14C_FILE", default=1) + else + call get_param(param_file, mdl, "D14C_FORCING_YEAR", forcing_file_forcing_year, & + "Year from D14C_FILE to use for forcing", default=1850) + endif + do m=1,3 + write(var_name, "(A,I0)") "MARBL_D14C_FILE_", m + write(file_name, "(A,I0,A)") "atm_delta_C14_CMIP6_sector", m, & + "_global_1850-2015_yearly_v2.0_c240202.nc" + call get_param(param_file, mdl, var_name, CS%d14c_dataset(m)%file_name, & + "The file in which the d14c forcing field can be found.", default=file_name) + call forcing_timeseries_set_time_type_vars(forcing_file_start_year, forcing_file_end_year, & + forcing_file_data_ref_year, forcing_file_model_ref_year, forcing_file_forcing_year, & + CS%d14c_dataset(m)) + if (scan(CS%d14c_dataset(m)%file_name,'/') == 0) then + ! Add the directory if CS%d14c_dataset%file_name is not already a complete path. + CS%d14c_dataset(m)%file_name = trim(slasher(inputdir))//trim(CS%d14c_dataset(m)%file_name) + call log_param(param_file, mdl, "INPUTDIR/D14C_FILE", CS%d14c_dataset(m)%file_name) + endif + enddo +endif + + ! ** Tracer Restoring + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_SOURCE", CS%restoring_source, & + "Source of data for restoring MARBL tracers", default="none") + select case(CS%restoring_source) + case("none") + case("file") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_FILE", CS%restoring_file, & + "File containing fields to restore MARBL tracers towards") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_SOURCE", & + CS%restoring_I_tau_source, "Source of data for inverse timescale for restoring MARBL tracers") + + ! Initialize remapping type + call initialize_remapping(CS%restoring_remapCS, 'PCM', boundary_extrapolation=.false., answer_date=99991231) + + ! Set up array for thicknesses in restoring file + call read_Z_edges(CS%restoring_file, "PO4", CS%restoring_z_edges, CS%restoring_nz, & + restoring_has_edges, restoring_use_missing, restoring_missing, scale=US%m_to_Z) + allocate(CS%restoring_dz(CS%restoring_nz)) + do k=CS%restoring_nz,1,-1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + CS%restoring_dz(k) = (CS%restoring_z_edges(k) - CS%restoring_z_edges(kbot)) * GV%Z_to_H + enddo + + select case(CS%restoring_I_tau_source) + case("file") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_FILE", & + CS%restoring_I_tau_file, & + "File containing the inverse timescale for restoring MARBL tracers") + call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_I_TAU_VAR_NAME", & + CS%restoring_I_tau_var_name, & + "Field containing the inverse timescale for restoring MARBL tracers", & + default="I_TAU") + ! Set up array for thicknesses in restoring timescale file + call read_Z_edges(CS%restoring_I_tau_file, CS%restoring_I_tau_var_name, CS%restoring_timescale_z_edges, & + CS%restoring_timescale_nz, restoring_timescale_has_edges, & + restoring_timescale_use_missing, restoring_timescale_missing, scale=US%m_to_Z) + allocate(CS%restoring_timescale_dz(CS%restoring_timescale_nz)) + do k=CS%restoring_timescale_nz,1,-1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + CS%restoring_timescale_dz(k) = (CS%restoring_timescale_z_edges(k) - & + CS%restoring_timescale_z_edges(kbot)) * GV%Z_to_H + enddo + case DEFAULT + write(log_message, "(3A)") "'", trim(CS%restoring_I_tau_source), & + "' is not a valid option for MARBL_TRACER_RESTORING_I_TAU_SOURCE" + call MOM_error(FATAL, log_message) + end select + case DEFAULT + write(log_message, "(3A)") "'", trim(CS%restoring_source), & + "' is not a valid option for MARBL_TRACER_RESTORING_SOURCE" + call MOM_error(FATAL, log_message) + end select + + allocate(CS%ind_tr(CS%ntr)) + allocate(CS%tr_desc(CS%ntr)) + allocate(CS%tracer_data(CS%ntr)) + + do m=1,CS%ntr + allocate(CS%tracer_data(m)%tr(isd:ied,jsd:jed,nz), source=0.0) + write(var_name(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%short_name) + write(desc_name(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%long_name) + write(units(:),'(A)') trim(MARBL_instances%tracer_metadata(m)%units) + CS%tr_desc(m) = var_desc(trim(var_name), trim(units), trim(desc_name), caller=mdl) + + ! This is needed to force the compiler not to do a copy in the registration + ! calls. Curses on the designers and implementers of Fortran90. + tr_ptr => CS%tracer_data(m)%tr(:,:,:) + call query_vardesc(CS%tr_desc(m), name=var_name, & + caller="register_MARBL_tracers") + ! Register the tracer for horizontal advection, diffusion, and restarts. + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, units = units, & + tr_desc=CS%tr_desc(m), registry_diags=.true., & + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit, & + Tr_out=CS%tracer_data(m)%tr_ptr) + + ! Set coupled_tracers to be true (hard-coded above) to provide the surface + ! values to the coupler (if any). This is meta-code and its arguments will + ! currently (deliberately) give fatal errors if it is used. + if (CS%coupled_tracers) & + CS%ind_tr(m) = aof_set_coupler_flux(trim(var_name)//'_flux', & + flux_type=' ', implementation=' ', caller="register_MARBL_tracers") + enddo + + ! Set up memory for saved state + call setup_saved_state(MARBL_instances%surface_flux_saved_state, HI, GV, restart_CS, & + CS%tracers_may_reinit, CS%surface_flux_saved_state) + call setup_saved_state(MARBL_instances%interior_tendency_saved_state, HI, GV, restart_CS, & + CS%tracers_may_reinit, CS%interior_tendency_saved_state) + + CS%tr_Reg => tr_Reg + CS%restart_CSp => restart_CS + + call set_riv_flux_tracer_inds(CS) + register_MARBL_tracers = .true. + +end function register_MARBL_tracers + +!> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) +!! and it sets up the tracer output. +subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag, OBC, CS, sponge_CSp) + logical, intent(in) :: restart !< .true. if the fields have already been + !! read from a restart file. + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies + !! whether, where, and what open boundary + !! conditions are used. + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + + ! Local variables + character(len=200) :: log_message + character(len=48) :: name ! A variable's name in a NetCDF file. + character(len=100) :: longname ! The long name of that variable. + character(len=48) :: units ! The units of the variable. + character(len=48) :: flux_units ! The units for age tracer fluxes, either + ! years m3 s-1 or years kg s-1. + character(len=48) :: tracer_name + logical :: fesedflux_has_edges, fesedflux_use_missing + real :: fesedflux_missing + integer :: i, j, k, kbot, m, diag_size + + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + CS%diag => diag + + ! Allocate memory for surface tracer fluxes + allocate(CS%STF(SZI_(G), SZJ_(G), CS%ntr), & + CS%RIV_FLUXES(SZI_(G), SZJ_(G), CS%ntr), & + CS%SFO(SZI_(G), SZJ_(G), CS%sfo_cnt), & + CS%ITO(SZI_(G), SZJ_(G), SZK_(G), CS%ito_cnt), & + source=0.0) + + ! Allocate memory for d14c forcing + if (CS%abio_dic_on) allocate(CS%d14c(SZI_(G), SZJ_(G))) + + ! Register diagnostics returned from MARBL (surface flux first, then interior tendency) + call register_MARBL_diags(MARBL_instances%surface_flux_diags, diag, day, G, CS%surface_flux_diags) + call register_MARBL_diags(MARBL_instances%interior_tendency_diags, diag, day, G, & + CS%interior_tendency_diags) + + ! Register per-tracer diagnostics computed from MARBL surface flux / interior tendency values + allocate(CS%id_surface_flux_out(CS%ntr)) + allocate(CS%interior_tendency_out(CS%ntr)) + allocate(CS%interior_tendency_out_zint(CS%ntr)) + allocate(CS%interior_tendency_out_zint_100m(CS%ntr)) + do m=1,CS%ntr + write(name, "(2A)") "STF_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Surface Flux" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%id_surface_flux_out(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units), conversion=US%Z_to_m*US%s_to_T) + + write(name, "(2A)") "J_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Source Sink Term" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), "/s" + CS%interior_tendency_out(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, trim(longname), trim(units)) + if (CS%interior_tendency_out(m)%id > 0) & + allocate(CS%interior_tendency_out(m)%field_3d(SZI_(G),SZJ_(G), SZK_(G)), source=0.0) + + write(name, "(2A)") "Jint_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), & + " Source Sink Term Vertical Integral" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%interior_tendency_out_zint(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + if (CS%interior_tendency_out_zint(m)%id > 0) & + allocate(CS%interior_tendency_out_zint(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + + write(name, "(2A)") "Jint_100m_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), & + " Source Sink Term Vertical Integral, 0-100m" + write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), " m/s" + CS%interior_tendency_out_zint_100m(m)%id = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + if (CS%interior_tendency_out_zint_100m(m)%id > 0) & + allocate(CS%interior_tendency_out_zint_100m(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + + enddo + + ! Register diagnostics for MOM to report that are not tracer specific + CS%bot_flux_to_tend_id = register_diag_field("ocean_model", "BOT_FLUX_TO_TEND", & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, "Conversion Factor for Bottom Flux -> Tend", "1/m") + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_MARBL_tracers") + if ((.not. restart) .or. & + (CS%tracers_may_reinit .and. & + .not. query_initialized(CS%tracer_data(m)%tr(:,:,:), name, CS%restart_CSp))) then + ! TODO: added the ongrid optional argument, but is there a good way to detect if the file is on grid? + call MOM_initialize_tracer_from_Z(h, CS%tracer_data(m)%tr, G, GV, US, param_file, & + CS%IC_file, name, ongrid=CS%ongrid) + do k=1,GV%ke + do j=G%jsc, G%jec + do i=G%isc, G%iec + ! Ensure tracer concentrations are at / above minimum value + if (CS%tracer_data(m)%tr(i,j,k) < CS%IC_min) CS%tracer_data(m)%tr(i,j,k) = CS%IC_min + enddo + enddo + enddo + endif + enddo + + ! Register diagnostics for river fluxes + CS%no3_riv_flux = register_diag_field("ocean_model", "NO3_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Nitrate Riverine Flux", "mmol/m^3 m/s") + CS%po4_riv_flux = register_diag_field("ocean_model", "PO4_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Phosphate Riverine Flux", "mmol/m^3 m/s") + CS%don_riv_flux = register_diag_field("ocean_model", "DON_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Nitrogen Riverine Flux", "mmol/m^3 m/s") + CS%donr_riv_flux = register_diag_field("ocean_model", "DONR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DON Riverine Flux", "mmol/m^3 m/s") + CS%dop_riv_flux = register_diag_field("ocean_model", "DOP_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Phosphorus Riverine Flux", "mmol/m^3 m/s") + CS%dopr_riv_flux = register_diag_field("ocean_model", "DOPR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DOP Riverine Flux", "mmol/m^3 m/s") + CS%sio3_riv_flux = register_diag_field("ocean_model", "SiO3_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Silicate Riverine Flux", "mmol/m^3 m/s") + CS%fe_riv_flux = register_diag_field("ocean_model", "Fe_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Iron Riverine Flux", "mmol/m^3 m/s") + CS%doc_riv_flux = register_diag_field("ocean_model", "DOC_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Organic Carbon Riverine Flux", "mmol/m^3 m/s") + CS%docr_riv_flux = register_diag_field("ocean_model", "DOCR_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Refractory DOC Riverine Flux", "mmol/m^3 m/s") + CS%alk_riv_flux = register_diag_field("ocean_model", "ALK_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Alkalinity Riverine Flux", "meq/m^3 m/s") + CS%alk_alt_co2_riv_flux = register_diag_field("ocean_model", "ALK_ALT_CO2_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Alkalinity Riverine Flux, Alternative CO2", "meq/m^3 m/s") + CS%dic_riv_flux = register_diag_field("ocean_model", "DIC_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Carbon Riverine Flux", "mmol/m^3 m/s") + CS%dic_alt_co2_riv_flux = register_diag_field("ocean_model", "DIC_ALT_CO2_RIV_FLUX", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Dissolved Inorganic Carbon Riverine Flux, Alternative CO2", "mmol/m^3 m/s") + + ! Register diagnostics for d14c forcing + if (CS%abio_dic_on) then + CS%d14c_id = register_diag_field("ocean_model", "D14C_FORCING", & + diag%axesT1, & ! T=> tracer grid? 1 => no vertical grid + day, "Delta-14C in atmospheric CO2", "per mil, relative to Modern") + endif + + ! Register diagnostics for per-category forcing fields + if (CS%ice_ncat > 0) then + allocate(CS%fracr_cat_id(CS%ice_ncat+1)) + allocate(CS%qsw_cat_id(CS%ice_ncat+1)) + do m=1,CS%ice_ncat+1 + write(name, "(A,I0)") "FRACR_CAT_", m + write(longname, "(A,I0)") "Fraction of area in ice category ", m + units = "fraction" + CS%fracr_cat_id(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + write(name, "(A,I0)") "QSW_CAT_", m + write(longname, "(A,I0)") "Shortwave penetrating through ice category ", m + units = "TODO: set units" + CS%qsw_cat_id(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units)) + enddo + endif + + if (CS%base_bio_on) then + ! Read initial fesedflux and feventflux fields + ! (1) get vertical dimension + ! -- comes from fesedflux_file, assume same dimension in feventflux + ! (maybe these fields should be combined?) + ! -- note: read_Z_edges treats depth as positive UP => 0 at surface, negative at depth + fesedflux_use_missing = .false. + call read_Z_edges(CS%fesedflux_file, "FESEDFLUXIN", CS%fesedflux_z_edges, CS%fesedflux_nz, & + fesedflux_has_edges, fesedflux_use_missing, fesedflux_missing, scale=US%m_to_Z) + + ! (2) Allocate memory for fesedflux and feventflux + allocate(CS%fesedflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + allocate(CS%feventflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + allocate(CS%fesedflux_dz(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + + ! (3) Read data + ! TODO: Add US term to scale + call MOM_read_data(CS%fesedflux_file, "FESEDFLUXIN", CS%fesedflux_in(:,:,:), G%Domain, & + scale=CS%fesedflux_scale_factor) + call MOM_read_data(CS%feventflux_file, "FESEDFLUXIN", CS%feventflux_in(:,:,:), G%Domain, & + scale=CS%fesedflux_scale_factor) + + ! (4) Relocate values that are below ocean bottom to layer that intersects bathymetry + ! Remember, fesedflux_z_edges = 0 at surface and is < 0 below surface + + do k=CS%fesedflux_nz, 1, -1 + kbot = k + 1 ! level k is between z(k) and z(k+1) + do j=G%jsc, G%jec + do i=G%isc, G%iec + if (G%mask2dT(i,j) == 0) cycle + if (G%bathyT(i,j) + CS%fesedflux_z_edges(1) < 1e-8 * US%m_to_Z) then + write(log_message, *) "Current implementation of fesedflux assumes G%bathyT >=", & + " first edge;first edge = ", -CS%fesedflux_z_edges(1), "bathyT = ", G%bathyT(i,j) + call MOM_error(FATAL, log_message) + endif + ! Also figure out layer thickness while we're here + CS%fesedflux_dz(i,j,k) = (CS%fesedflux_z_edges(k) - CS%fesedflux_z_edges(kbot)) * GV%Z_to_H + ! If top interface is at or below ocean bottom, move flux in current layer up one + ! and set thickness of current level to 0 + if (G%bathyT(i,j) + CS%fesedflux_z_edges(k) < 1e-8 * US%m_to_Z) then + CS%fesedflux_in(i,j,k-1) = CS%fesedflux_in(i,j,k-1) + CS%fesedflux_in(i,j,k) + CS%fesedflux_in(i,j,k) = 0. + CS%feventflux_in(i,j,k-1) = CS%feventflux_in(i,j,k-1) + CS%feventflux_in(i,j,k) + CS%feventflux_in(i,j,k) = 0. + CS%fesedflux_dz(i,j,k) = 0. + elseif (G%bathyT(i,j) + CS%fesedflux_z_edges(kbot) < 1e-8 * US%m_to_Z) then + ! Otherwise, if lower interface is below bathymetry move interface to ocean bottom + CS%fesedflux_dz(i,j,k) = (G%bathyT(i,j) + CS%fesedflux_z_edges(k)) * GV%Z_to_H + endif + enddo + enddo + enddo + + ! Initialize external field for river fluxes + if (CS%read_riv_fluxes) then + CS%id_din_riv = init_external_field(CS%riv_flux_dataset%file_name, 'din_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_don_riv = init_external_field(CS%riv_flux_dataset%file_name, 'don_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dip_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dip_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dop_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dop_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dsi_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dsi_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dfe_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dfe_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_dic_riv = init_external_field(CS%riv_flux_dataset%file_name, 'dic_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_alk_riv = init_external_field(CS%riv_flux_dataset%file_name, 'alk_riv_flux', & + domain=G%Domain%mpp_domain) + CS%id_doc_riv = init_external_field(CS%riv_flux_dataset%file_name, 'doc_riv_flux', & + domain=G%Domain%mpp_domain) + endif + endif + + if (CS%abio_dic_on) then + ! Initialize external field for d14c forcing + do m=1,3 + CS%id_d14c(m) = init_external_field(CS%d14c_dataset(m)%file_name, "Delta14co2_in_air", & + ignore_axis_atts=.true.) + enddo + endif + + ! Initialize external field for restoring + if (CS%restoring_I_tau_source == "file") then + select case(CS%restoring_source) + case("file") + ! Set up array for reading in raw restoring data + allocate(CS%restoring_in(SZI_(G), SZJ_(G), CS%restoring_nz, CS%restore_count), source=0.) + do m=1,CS%restore_count + CS%id_tracer_restoring(m) = init_external_field(CS%restoring_file, & + trim(CS%tracer_restoring_varname(m)), domain=G%Domain%mpp_domain) + enddo + end select + select case(CS%restoring_I_tau_source) + case("file") + allocate(CS%I_tau(SZI_(G), SZJ_(G), CS%restoring_timescale_nz), source=0.) + call MOM_read_data(CS%restoring_I_tau_file, "RTAU", CS%I_tau(:,:,:), G%Domain) + end select + endif + +end subroutine initialize_MARBL_tracers + +!> This subroutine is used to register tracer fields and subroutines +!! to be used with MOM. +subroutine register_MARBL_diags(MARBL_diags, diag, day, G, id_diags) + + type(marbl_diagnostics_type), intent(in) :: MARBL_diags !< MARBL diagnostics from MARBL_instances + type(time_type), target, intent(in) :: day !< Time of the start of the run. + type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. + !integer, allocatable, intent(inout) :: id_diags(:) !< allocatable array storing diagnostic index number + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(temp_marbl_diag), allocatable, intent(inout) :: id_diags(:) !< allocatable array storing diagnostic index + !! number and buffer space for collecting diags + !! from all columns + + integer :: m, diag_size + + diag_size = size(MARBL_diags%diags) + allocate(id_diags(diag_size)) + do m = 1, diag_size + id_diags(m)%id = -1 + if (trim(MARBL_diags%diags(m)%vertical_grid) .eq. "none") then ! 2D field + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units)) + if (id_diags(m)%id > 0) allocate(id_diags(m)%field_2d(SZI_(G),SZJ_(G)), source=0.0) + else ! 3D field + ! TODO: MARBL should provide v_extensive through MARBL_diags + ! (for now, FESEDFLUX is the only one that should be true) + ! Also, known issue where passing v_extensive=.false. isn't + ! treated the same as not passing v_extensive + if (trim(MARBL_diags%diags(m)%short_name).eq."FESEDFLUX") then + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units), & + v_extensive=.true.) + else + id_diags(m)%id = register_diag_field("ocean_model", & + trim(MARBL_diags%diags(m)%short_name), & + diag%axesTL, & ! T=> tracer grid? L => layer center + day, & + trim(MARBL_diags%diags(m)%long_name), & + trim(MARBL_diags%diags(m)%units)) + endif + if (id_diags(m)%id > 0) allocate(id_diags(m)%field_3d(SZI_(G),SZJ_(G), SZK_(G)), source=0.0) + endif + enddo + +end subroutine register_MARBL_diags + +!> This subroutine allocates memory for saved state fields and registers them in the restart files +subroutine setup_saved_state(MARBL_saved_state, HI, GV, restart_CS, tracers_may_reinit, & + local_saved_state) + + type(marbl_saved_state_type), intent(in) :: MARBL_saved_state !< MARBL saved state from + !! MARBL_instances + type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(MOM_restart_CS), pointer, intent(in) :: restart_CS !< control structure to add saved state + !! to restarts + logical, intent(in) :: tracers_may_reinit !< used to determine mandatory + !! flag in restart + type(saved_state_for_MARBL_type), allocatable, intent(inout) :: local_saved_state(:) !< allocatable array for local + !! saved state + + integer :: num_fields, m + character(len=200) :: log_message, varname + + num_fields = MARBL_saved_state%saved_state_cnt + allocate(local_saved_state(num_fields)) + + do m=1,num_fields + write(varname, "(2A)") "MARBL_", trim(MARBL_saved_state%state(m)%short_name) + select case (MARBL_saved_state%state(m)%rank) + case (2) + allocate(local_saved_state(m)%field_2d(SZI_(HI),SZJ_(HI)), source=0.0) + call register_restart_field(local_saved_state(m)%field_2d, varname, & + .not.tracers_may_reinit, restart_CS) + case (3) + if (trim(MARBL_saved_state%state(m)%vertical_grid).eq."layer_avg") then + allocate(local_saved_state(m)%field_3d(SZI_(HI),SZJ_(HI), SZK_(GV)), source=0.0) + call register_restart_field(local_saved_state(m)%field_3d, varname, & + .not.tracers_may_reinit, restart_CS) + else + write(log_message, "(3A, I0, A)") "'", trim(MARBL_saved_state%state(m)%vertical_grid), & + "' is an invalid vertical grid for saved state (ind = ", m, ")" + call MOM_error(FATAL, log_message) + endif + case DEFAULT + write(log_message, "(I0, A, I0, A)") MARBL_saved_state%state(m)%rank, & + " is an invalid rank for saved state (ind = ", m, ")" + call MOM_error(FATAL, log_message) + end select + local_saved_state(m)%short_name = trim(MARBL_saved_state%state(m)%short_name) + write(local_saved_state(m)%file_varname, "(2A)") "MARBL_", trim(local_saved_state(m)%short_name) + local_saved_state(m)%units = trim(MARBL_saved_state%state(m)%units) + enddo + +end subroutine setup_saved_state + +!> This subroutine applies diapycnal diffusion and any other column +!! tracer physics or chemistry to the tracers from this file. +subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, tv, & + KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: ea !< an array to which the amount of fluid entrained + !! from the layer above during this call will be + !! added [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: eb !< an array to which the amount of fluid entrained + !! from the layer below during this call will be + !! added [H ~> m or kg m-2]. + type(forcing), intent(in) :: fluxes !< A structure containing pointers to thermodynamic + !! and tracer forcing fields. Unused fields have NULL ptrs. + real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure + real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [nondim] + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which + !! fluxes can be applied [m] + +! Local variables + character(len=256) :: log_message + real, dimension(SZI_(G),SZJ_(G)) :: ref_mask ! Mask for 2D MARBL diags using ref_depth + real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: bot_flux_to_tend + real :: cum_bftt_dz ! sum of bot_flux_to_tend * dz from the bottom layer to current layer + real :: sfc_val ! The surface value for the tracers. + real :: Isecs_per_year ! The number of seconds in a year. + real :: year ! The time in years. + integer :: secs, days ! Integer components of the time type. + real, dimension(0:GV%ke) :: zi ! z-coordinate interface depth [Z ~> m] + real, dimension(GV%ke) :: zc ! z-coordinate layer center depth [Z ~> m] + real, dimension(GV%ke) :: dz ! z-coordinate cell thickness [H ~> m] + integer :: i, j, k, is, ie, js, je, nz, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + if (.not.associated(CS)) return + + ! (1) Compute surface fluxes + ! FIXME: MARBL can handle computing surface fluxes for all columns simultaneously + ! I was just thinking going column-by-column at first might be easier + do j=js,je + do i=is,ie + ! i. only want ocean points in this loop + if (G%mask2dT(i,j) == 0) cycle + + ! ii. Load proper column data + ! * surface flux forcings + ! These fields are getting the correct data + ! TODO: if top layer is vanishly thin, do we actually want (e.g.) top 5m average temp / salinity? + ! How does MOM pass SST and SSS to GFDL coupler? (look in core.F90?) + if (CS%sss_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%sss_ind)%field_0d(1) = tv%S(i,j,1) * US%S_to_ppt + if (CS%sst_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%sst_ind)%field_0d(1) = tv%T(i,j,1) * US%C_to_degC + if (CS%ifrac_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%ifrac_ind)%field_0d(1) = fluxes%ice_fraction(i,j) + + ! MARBL wants u10_sqr in (m/s)^2 + if (CS%u10_sqr_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%u10_sqr_ind)%field_0d(1) = fluxes%u10_sqr(i,j) * & + ((US%L_T_to_m_s)**2) + + ! mct_driver/ocn_cap_methods:93 -- ice_ocean_boundary%p(i,j) comes from coupler + ! We may need a new ice_ocean_boundary%p_atm because %p includes ice in GFDL driver + if (CS%atmpress_ind > 0) then + if (associated(fluxes%p_surf_full)) then + MARBL_instances%surface_flux_forcings(CS%atmpress_ind)%field_0d(1) = & + fluxes%p_surf_full(i,j) * ((US%R_to_kg_m3 * (US%L_T_to_m_s**2)) * atm_per_Pa) + else + ! hardcode value of 1 atm (can't figure out how to get this from solo_driver) + MARBL_instances%surface_flux_forcings(CS%atmpress_ind)%field_0d(1) = 1. + endif + endif + + ! These are okay, but need option to come in from coupler + if (CS%xco2_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%xco2_ind)%field_0d(1) = fluxes%atm_co2(i,j) + if (CS%xco2_alt_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%xco2_alt_ind)%field_0d(1) = fluxes%atm_alt_co2(i,j) + + ! These are okay, but need option to read in from file + if (CS%dust_dep_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%dust_dep_ind)%field_0d(1) = & + fluxes%dust_flux(i,j) * US%RZ_T_to_kg_m2s + + if (CS%fe_dep_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%fe_dep_ind)%field_0d(1) = & + fluxes%iron_flux(i,j) * (US%Z_to_m * US%s_to_T) + + ! MARBL wants ndep in (mmol/m^2/s) + if (CS%nox_flux_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%nox_flux_ind)%field_0d(1) = fluxes%noy_dep(i,j) * & + (US%Z_to_m * US%s_to_T) + if (CS%nhy_flux_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%nhy_flux_ind)%field_0d(1) = fluxes%nhx_dep(i,j) * & + (US%Z_to_m * US%s_to_T) + + if (CS%d14c_ind > 0) & + MARBL_instances%surface_flux_forcings(CS%d14c_ind)%field_0d(1) = CS%d14c(i,j) + + ! * tracers at surface + ! TODO: average over some shallow depth (e.g. 5m) + do m=1,CS%ntr + MARBL_instances%tracers_at_surface(1,m) = CS%tracer_data(m)%tr(i,j,1) + enddo + + ! * surface flux saved state + do m=1,size(MARBL_instances%surface_flux_saved_state%state) + ! (currently only 2D fields are saved from surface_flux_compute()) + MARBL_instances%surface_flux_saved_state%state(m)%field_2d(1) = & + CS%surface_flux_saved_state(m)%field_2d(i,j) + enddo + + ! iii. Compute surface fluxes in MARBL + call MARBL_instances%surface_flux_compute() + if (MARBL_instances%StatusLog%labort_marbl) then + call MARBL_instances%StatusLog%log_error_trace("MARBL_instances%surface_flux_compute()", & + "MARBL_tracers_column_physics") + endif + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + + ! iv. Copy output that MOM6 needs to hold on to + ! * saved state + do m=1,size(MARBL_instances%surface_flux_saved_state%state) + CS%surface_flux_saved_state(m)%field_2d(i,j) = & + MARBL_instances%surface_flux_saved_state%state(m)%field_2d(1) + enddo + + ! * diagnostics + do m=1,size(MARBL_instances%surface_flux_diags%diags) + ! All diags are 2D coming from surface + if (CS%surface_flux_diags(m)%id > 0) & + CS%surface_flux_diags(m)%field_2d(i,j) = & + real(MARBL_instances%surface_flux_diags%diags(m)%field_2d(1)) + enddo + + ! * Surface tracer flux + CS%STF(i,j,:) = MARBL_instances%surface_fluxes(1,:) * (US%m_to_Z * US%T_to_s) + + ! * Surface flux output + do m=1,CS%sfo_cnt + CS%SFO(i,j,m) = MARBL_instances%surface_flux_output%outputs_for_GCM(m)%forcing_field_0d(1) + enddo + + enddo + enddo + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%STF(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//" sfc_flux", G%HI, & + scale=US%Z_to_m*US%s_to_T) + enddo + endif + + ! (2) Post surface fluxes and their diagnostics (currently all 2D) + do m=1,CS%ntr + if (CS%id_surface_flux_out(m) > 0) & + call post_data(CS%id_surface_flux_out(m), CS%STF(:,:,m), CS%diag) + enddo + do m=1,size(CS%surface_flux_diags) + if (CS%surface_flux_diags(m)%id > 0) & + call post_data(CS%surface_flux_diags(m)%id, CS%surface_flux_diags(m)%field_2d(:,:), CS%diag) + enddo + + ! (3) Apply surface fluxes via vertical diffusion + ! Compute KPP nonlocal term if necessary + if (present(KPP_CSp)) then + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + do m=1,CS%ntr + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, CS%STF(:,:,m), dt, & + CS%diag, CS%tracer_data(m)%tr_ptr, CS%tracer_data(m)%tr(:,:,:), & + flux_scale=GV%Z_to_H) + enddo + endif + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post KPP', G%HI) + enddo + endif + endif + + if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then + do m=1,CS%ntr + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + ! CS%RIV_FLUXES is conc m/s, in_flux_optional expects time-integrated flux (conc H) + do j=js,je ; do i=is,ie + riv_flux_loc(i,j) = (CS%RIV_FLUXES(i,j,m) * (dt*US%T_to_s)) * GV%m_to_H + enddo ; enddo + if (CS%debug) & + call hchksum(riv_flux_loc(:,:), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' riv flux', G%HI, scale=GV%H_to_m) + call applyTracerBoundaryFluxesInOut(G, GV, CS%tracer_data(m)%tr(:,:,:) , dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth, in_flux_optional=riv_flux_loc) + call tracer_vertdiff(h_work, ea, eb, dt, CS%tracer_data(m)%tr(:,:,:), G, GV, & + sfc_flux=GV%Rho0 * CS%STF(:,:,m)) + enddo + else + do m=1,CS%ntr + call tracer_vertdiff(h_old, ea, eb, dt, CS%tracer_data(m)%tr(:,:,:), G, GV, & + sfc_flux=GV%Rho0 * CS%STF(:,:,m)) + enddo + endif + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post tracer_vertdiff', G%HI) + enddo + endif + + ! (4) Compute interior tendencies + + bot_flux_to_tend(:, :, :) = 0. + do j=js,je + do i=is,ie + ! i. only want ocean points in this loop + if (G%mask2dT(i,j) == 0) cycle + + ! ii. Set up vertical domain and bot_flux_to_tend + ! Calculate depth of interface by building up thicknesses from the bottom (top interface is always 0) + ! MARBL wants this to be positive-down + zi(GV%ke) = G%bathyT(i,j) + MARBL_instances%bot_flux_to_tend(:) = 0. + cum_bftt_dz = 0. + do k = GV%ke, 1, -1 + ! TODO: if we move this above vertical mixing, use h_old + dz(k) = h_new(i,j,k) ! cell thickness + zc(k) = zi(k) - 0.5 * (dz(k)*GV%H_to_Z) + zi(k-1) = zi(k) - (dz(k)*GV%H_to_Z) + if (G%bathyT(i,j) - zi(k-1) <= CS%bot_flux_mix_thickness) then + MARBL_instances%bot_flux_to_tend(k) = US%m_to_Z * CS%Ibfmt + cum_bftt_dz = cum_bftt_dz + MARBL_instances%bot_flux_to_tend(k) * (GV%H_to_m * dz(k)) + elseif (G%bathyT(i,j) - zi(k) < CS%bot_flux_mix_thickness) then + ! MARBL_instances%bot_flux_to_tend(k) = (1. - (G%bathyT(i,j) - zi(k)) * CS%Ibfmt) / dz(k) + MARBL_instances%bot_flux_to_tend(k) = (1. - cum_bftt_dz) / (GV%H_to_m * dz(k)) + endif + enddo + if (G%bathyT(i,j) - zi(0) < CS%bot_flux_mix_thickness) & + MARBL_instances%bot_flux_to_tend(:) = MARBL_instances%bot_flux_to_tend(:) * & + CS%bot_flux_mix_thickness / (G%bathyT(i,j) - zi(0)) + if (CS%bot_flux_to_tend_id > 0) & + bot_flux_to_tend(i, j, :) = MARBL_instances%bot_flux_to_tend(:) + + ! zw(1:nz) is bottom cell depth so no element of zw = 0, it is assumed to be top layer depth + MARBL_instances%domain%zw(:) = US%Z_to_m * zi(1:GV%ke) + MARBL_instances%domain%zt(:) = US%Z_to_m * zc(:) + MARBL_instances%domain%delta_z(:) = GV%H_to_m * dz(:) + + ! iii. Load proper column data + ! * Forcing Fields + ! These fields are getting the correct data + if (CS%potemp_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%potemp_ind)%field_1d(1,:) = tv%T(i,j,:) * US%C_to_degC + if (CS%salinity_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%salinity_ind)%field_1d(1,:) = tv%S(i,j,:) * US%S_to_ppt + + ! This are okay, but need option to read in from file + ! (Same as dust_dep_ind for surface_flux_forcings) + if (CS%dustflux_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%dustflux_ind)%field_0d(1) = & + fluxes%dust_flux(i,j) * US%RZ_T_to_kg_m2s + + ! TODO: Support PAR (currently just using single subcolumn) + ! (Look for Pen_sw_bnd?) + if (CS%PAR_col_frac_ind > 0) then + ! second index is num_subcols, not depth + !MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,:) = fluxes%fracr_cat(i,j,:) + if (CS%use_ice_category_fields) then + MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,:) = & + fluxes%fracr_cat(i,j,:) + else + MARBL_instances%interior_tendency_forcings(CS%PAR_col_frac_ind)%field_1d(1,1) = 1. + endif + endif + + if (CS%surf_shortwave_ind > 0) then + ! second index is num_subcols, not depth + if (CS%use_ice_category_fields) then + MARBL_instances%interior_tendency_forcings(CS%surf_shortwave_ind)%field_1d(1,:) = & + fluxes%qsw_cat(i,j,:) + else + MARBL_instances%interior_tendency_forcings(CS%surf_shortwave_ind)%field_1d(1,1) = & + fluxes%sw(i,j) * US%QRZ_T_to_W_m2 + endif + endif + ! Tracer restoring + do m=1,CS%restore_count + MARBL_instances%interior_tendency_forcings(CS%tracer_restoring_ind(m))%field_1d(1,:) = 0. + call remapping_core_h(CS%restoring_remapCS, CS%restoring_nz, CS%restoring_dz(:), & + CS%restoring_in(i,j,:,m), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%tracer_restoring_ind(m))%field_1d(1,:)) + if (m==1) then + call remapping_core_h(CS%restoring_remapCS, CS%restoring_timescale_nz, & + CS%restoring_timescale_dz(:), CS%I_tau(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(m))%field_1d(1,:)) + else + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(m))%field_1d(1,:) = & + MARBL_instances%interior_tendency_forcings(CS%tracer_I_tau_ind(1))%field_1d(1,:) + endif + enddo + + ! TODO: In POP, pressure comes from a function in state_mod.F90; I don't see a similar function here + ! This formulation is from Levitus 1994, and I think it belongs in MOM_EOS.F90? + ! Converts depth [m] -> pressure [bars] + ! NOTE: Andrew recommends using GV%H_to_Pa + if (CS%pressure_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%pressure_ind)%field_1d(1,:) = & + (0.0598088 * (exp(-0.025*US%Z_to_m * zc(:)) - 1.)) + & + (0.100766 * US%Z_to_m * zc(:)) + (2.28405e-7*((US%Z_to_m * zc(:))**2)) + + if (CS%fesedflux_ind > 0) then + MARBL_instances%interior_tendency_forcings(CS%fesedflux_ind)%field_1d(1,:) = 0. + call reintegrate_column(CS%fesedflux_nz, & + CS%fesedflux_dz(i,j,:) * (sum(dz(:) * GV%H_to_Z) / G%bathyT(i,j)), & + CS%fesedflux_in(i,j,:) + CS%feventflux_in(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%fesedflux_ind)%field_1d(1,:)) + endif + + ! TODO: add ability to read these fields from file + ! also, add constant values to CS + if (CS%o2_scalef_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%o2_scalef_ind)%field_1d(1,:) = 1. + if (CS%remin_scalef_ind > 0) & + MARBL_instances%interior_tendency_forcings(CS%remin_scalef_ind)%field_1d(1,:) = 1. + + ! * Column Tracers + do m=1,CS%ntr + MARBL_instances%tracers(m, :) = CS%tracer_data(m)%tr(i,j,:) + enddo + + ! * interior tendency saved state + ! (currently only 3D fields are saved from interior_tendency_compute()) + do m=1,size(MARBL_instances%interior_tendency_saved_state%state) + MARBL_instances%interior_tendency_saved_state%state(m)%field_3d(:,1) = & + CS%interior_tendency_saved_state(m)%field_3d(i,j,:) + enddo + + ! iv. Compute interior tendencies in MARBL + call MARBL_instances%interior_tendency_compute() + if (MARBL_instances%StatusLog%labort_marbl) then + call MARBL_instances%StatusLog%log_error_trace(& + "MARBL_instances%interior_tendency_compute()", "MARBL_tracers_column_physics") + endif + call print_marbl_log(MARBL_instances%StatusLog, G, i, j) + call MARBL_instances%StatusLog%erase() + + ! v. Apply tendencies immediately + ! First pass - Euler step; if stability issues, we can do something different (subcycle?) + do m=1,CS%ntr + CS%tracer_data(m)%tr(i,j,:) = CS%tracer_data(m)%tr(i,j,:) + (dt * US%T_to_s) * & + MARBL_instances%interior_tendencies(m,:) + enddo + + ! vi. Copy output that MOM6 needs to hold on to + ! * saved state + do m=1,size(MARBL_instances%interior_tendency_saved_state%state) + CS%interior_tendency_saved_state(m)%field_3d(i,j,:) = & + MARBL_instances%interior_tendency_saved_state%state(m)%field_3d(:,1) + enddo + + ! * diagnostics + do m=1,size(MARBL_instances%interior_tendency_diags%diags) + if (CS%interior_tendency_diags(m)%id > 0) then + if (allocated(CS%interior_tendency_diags(m)%field_2d)) then + ! Only copy values if ref_depth < bathyT + if (G%bathyT(i,j) > real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth)) then + CS%interior_tendency_diags(m)%field_2d(i,j) = & + real(MARBL_instances%interior_tendency_diags%diags(m)%field_2d(1)) + endif + else ! not a 2D diagnostic + CS%interior_tendency_diags(m)%field_3d(i,j,:) = & + real(MARBL_instances%interior_tendency_diags%diags(m)%field_3d(:,1)) + endif + endif + enddo + + ! * tendency values themselves (and vertical integrals of them) + do m=1,CS%ntr + if (allocated(CS%interior_tendency_out(m)%field_3d)) & + CS%interior_tendency_out(m)%field_3d(i,j,:) = MARBL_instances%interior_tendencies(m,:) + + if (allocated(CS%interior_tendency_out_zint(m)%field_2d)) & + CS%interior_tendency_out_zint(m)%field_2d(i,j) = (sum(dz(:) * & + MARBL_instances%interior_tendencies(m,:))) + + if (allocated(CS%interior_tendency_out_zint_100m(m)%field_2d)) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = 0. + do k=1,GV%ke + if (zi(k) < US%m_to_Z * 100.) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = & + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) + GV%H_to_m * dz(k) * & + MARBL_instances%interior_tendencies(m,k) + elseif (zi(k-1) < US%m_to_Z * 100.) then + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) = & + CS%interior_tendency_out_zint_100m(m)%field_2d(i,j) + GV%H_to_m * dz(k) * & + ((US%m_to_Z * 100. - zi(k-1)) / (zi(k) - zi(k-1))) * & + MARBL_instances%interior_tendencies(m,k) + else + exit + endif + enddo + endif + enddo + + ! * Interior tendency output + do m=1,CS%ito_cnt + CS%ITO(i,j,:,m) = & + MARBL_instances%interior_tendency_output%outputs_for_GCM(m)%forcing_field_1d(1,:) + enddo + + enddo + enddo + + if (CS%debug) then + do m=1,CS%ntr + call hchksum(CS%tracer_data(m)%tr(:,:,m), & + trim(MARBL_instances%tracer_metadata(m)%short_name)//' post source-sink', G%HI) + enddo + endif + + ! (5) Post diagnostics from our buffer + ! i. Interior tendency diagnostics (mix of 2D and 3D) + ! ii. Interior tendencies themselves + ! iii. Forcing fields + if (CS%bot_flux_to_tend_id > 0) & + call post_data(CS%bot_flux_to_tend_id, bot_flux_to_tend(:, :, :), CS%diag) + + do m=1,size(CS%interior_tendency_diags) + if (CS%interior_tendency_diags(m)%id > 0) then + if (allocated(CS%interior_tendency_diags(m)%field_2d)) then + if (real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth) == 0.) then + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_2d(:,:), CS%diag) + else ! non-zero ref-depth + ref_mask(:, :) = 0. + do j=js,je ; do i=is,ie + if (G%bathyT(i,j) > real(MARBL_instances%interior_tendency_diags%diags(m)%ref_depth)) & + ref_mask(i,j) = 1. + enddo ; enddo + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_2d(:,:), CS%diag, mask=ref_mask(:,:)) + endif + elseif (allocated(CS%interior_tendency_diags(m)%field_3d)) then + call post_data(CS%interior_tendency_diags(m)%id, & + CS%interior_tendency_diags(m)%field_3d(:,:,:), CS%diag) + else + write(log_message, "(A, I0, A, I0, A)") "Diagnostic number ", m, " post id ", & + CS%interior_tendency_diags(m)%id," did not allocate 2D or 3D array" + call MOM_error(FATAL, log_message) + endif + endif + enddo + + do m=1,CS%ntr + if (allocated(CS%interior_tendency_out(m)%field_3d)) & + call post_data(CS%interior_tendency_out(m)%id, & + CS%interior_tendency_out(m)%field_3d(:,:,:), CS%diag) + if (allocated(CS%interior_tendency_out_zint(m)%field_2d)) & + call post_data(CS%interior_tendency_out_zint(m)%id, & + CS%interior_tendency_out_zint(m)%field_2d(:,:), CS%diag) + if (allocated(CS%interior_tendency_out_zint_100m(m)%field_2d)) & + call post_data(CS%interior_tendency_out_zint_100m(m)%id, & + CS%interior_tendency_out_zint_100m(m)%field_2d(:,:), CS%diag) + enddo + + if (CS%ice_ncat > 0) then + do m=1,CS%ice_ncat+1 + if (CS%fracr_cat_id(m) > 0) & + call post_data(CS%fracr_cat_id(m), fluxes%fracr_cat(:,:,m), CS%diag) + if (CS%qsw_cat_id(m) > 0) & + call post_data(CS%qsw_cat_id(m), fluxes%qsw_cat(:,:,m), CS%diag) + enddo + endif + + +end subroutine MARBL_tracers_column_physics + +!> This subroutine reads time-varying forcing from files +subroutine MARBL_tracers_set_forcing(day_start, G, CS) + + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a + + ! Fraction of river nutrients in refractory pools + real, parameter :: DONriv_refract = 0.1 + real, parameter :: DOCriv_refract = 0.2 + real, parameter :: DOPriv_refract = 0.025 + + real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_in !< The field read in from forcing file with time dimension + type(time_type) :: Time_forcing !< For reading river flux fields, we use a modified version of Time + integer :: i, j, k, is, ie, js, je, m + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Abiotic DIC forcing + if (CS%abio_dic_on) then + ! Read d14c bands + do m=1,3 + Time_forcing = map_model_time_to_forcing_time(day_start, CS%d14c_dataset(m)) + call time_interp_external(CS%id_d14c(m),Time_forcing,CS%d14c_bands(m)) + enddo + + ! Set d14c according to the bands + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) > 30.) then + CS%d14c(i,j) = CS%d14c_bands(1) + elseif (G%geoLatT(i,j) > -30.) then + CS%d14c(i,j) = CS%d14c_bands(2) + else + CS%d14c(i,j) = CS%d14c_bands(3) + endif + enddo ; enddo + endif + + ! River fluxes + if (CS%read_riv_fluxes) then + CS%RIV_FLUXES(:,:,:) = 0. + Time_forcing = map_model_time_to_forcing_time(day_start, CS%riv_flux_dataset) + + ! DIN river flux affects NO3, ALK, and ALK_ALT_CO2 + call time_interp_external(CS%id_din_riv,Time_forcing,riv_flux_in) + + if (CS%tracer_inds%no3_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%no3_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) = CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) - & + G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) = & + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) - G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dip_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%po4_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%po4_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_don_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%don_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%don_ind) = G%mask2dT(i,j) * (1. - DONriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%donr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%donr_ind) = G%mask2dT(i,j) * DONriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dop_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%dop_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dop_ind) = G%mask2dT(i,j) * (1. - DOPriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%dopr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dopr_ind) = G%mask2dT(i,j) * DOPriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dsi_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%sio3_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%sio3_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dfe_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%fe_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%fe_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_dic_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%dic_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dic_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%dic_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%dic_alt_co2_ind) = G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_alk_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%alk_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) = CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_ind) + & + G%mask2dT(i,j) *riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%alk_alt_co2_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) = & + CS%RIV_FLUXES(i,j,CS%tracer_inds%alk_alt_co2_ind) + G%mask2dT(i,j) * riv_flux_in(i,j) + enddo ; enddo + endif + + call time_interp_external(CS%id_doc_riv,Time_forcing,riv_flux_in) + if (CS%tracer_inds%doc_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%doc_ind) = G%mask2dT(i,j) * (1. - DOCriv_refract) * & + riv_flux_in(i,j) + enddo ; enddo + endif + if (CS%tracer_inds%docr_ind > 0) then + do j=js,je ; do i=is,ie + CS%RIV_FLUXES(i,j,CS%tracer_inds%docr_ind) = G%mask2dT(i,j) * DOCriv_refract * & + riv_flux_in(i,j) + enddo ; enddo + endif + endif + + ! Tracer restoring + do m=1,CS%restore_count + call time_interp_external(CS%id_tracer_restoring(m),day_start,CS%restoring_in(:,:,:,m)) + do k=1,CS%restoring_nz ; do j=js,je ; do i=is,ie + CS%restoring_in(i,j,k,m) = G%mask2dT(i,j) * CS%restoring_in(i,j,k,m) + enddo ; enddo ; enddo + enddo + + ! Post Forcing to Diagnostics + if (CS%read_riv_fluxes) then + if (CS%no3_riv_flux > 0 .and. CS%tracer_inds%no3_ind > 0) & + call post_data(CS%no3_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%no3_ind), CS%diag) + if (CS%po4_riv_flux > 0 .and. CS%tracer_inds%po4_ind > 0) & + call post_data(CS%po4_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%po4_ind), CS%diag) + if (CS%don_riv_flux > 0 .and. CS%tracer_inds%don_ind > 0) & + call post_data(CS%don_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%don_ind), CS%diag) + if (CS%donr_riv_flux > 0 .and. CS%tracer_inds%donr_ind > 0) & + call post_data(CS%donr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%donr_ind), CS%diag) + if (CS%dop_riv_flux > 0 .and. CS%tracer_inds%dop_ind > 0) & + call post_data(CS%dop_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dop_ind), CS%diag) + if (CS%dopr_riv_flux > 0 .and. CS%tracer_inds%dopr_ind > 0) & + call post_data(CS%dopr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dopr_ind), CS%diag) + if (CS%sio3_riv_flux > 0 .and. CS%tracer_inds%sio3_ind > 0) & + call post_data(CS%sio3_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%sio3_ind), CS%diag) + if (CS%fe_riv_flux > 0 .and. CS%tracer_inds%fe_ind > 0) & + call post_data(CS%fe_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%fe_ind), CS%diag) + if (CS%doc_riv_flux > 0 .and. CS%tracer_inds%doc_ind > 0) & + call post_data(CS%doc_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%doc_ind), CS%diag) + if (CS%docr_riv_flux > 0 .and. CS%tracer_inds%docr_ind > 0) & + call post_data(CS%docr_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%docr_ind), CS%diag) + if (CS%alk_riv_flux > 0 .and. CS%tracer_inds%alk_ind > 0) & + call post_data(CS%alk_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%alk_ind), CS%diag) + if (CS%alk_alt_co2_riv_flux > 0 .and. CS%tracer_inds%alk_alt_co2_ind > 0) & + call post_data(CS%alk_alt_co2_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%alk_alt_co2_ind), & + CS%diag) + if (CS%dic_riv_flux > 0 .and. CS%tracer_inds%dic_ind > 0) & + call post_data(CS%dic_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dic_ind), CS%diag) + if (CS%dic_alt_co2_riv_flux > 0 .and. CS%tracer_inds%dic_alt_co2_ind > 0) & + call post_data(CS%dic_alt_co2_riv_flux, CS%RIV_FLUXES(:,:,CS%tracer_inds%dic_alt_co2_ind), & + CS%diag) + endif + if (CS%abio_dic_on) then + if (CS%d14c_id > 0) & + call post_data(CS%d14c_id, CS%d14c, CS%diag) + endif + +end subroutine MARBL_tracers_set_forcing + +!> This function calculates the mass-weighted integral of all tracer stocks, +!! returning the number of stocks it has calculated. If the stock_index +!! is present, only the stock corresponding to that coded index is returned. +function MARBL_tracers_stock(h, stocks, G, GV, CS, names, units, stock_index) + real, dimension(NIMEM_,NJMEM_,NKMEM_), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of + !! each tracer, in kg times concentration units + !! [kg conc]. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_MARBL_tracers. + character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. + character(len=*), dimension(:), intent(out) :: units !< the units of the stocks calculated. + integer, optional, intent(in) :: stock_index !< the coded index of a specific stock + !! being sought. + integer :: MARBL_tracers_stock !< Return value: the number of stocks + !! calculated here. + +! Local variables + integer :: i, j, k, is, ie, js, je, nz, m + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + MARBL_tracers_stock = 0 + if (.not.associated(CS)) return + if (CS%ntr < 1) return + + if (present(stock_index)) then ; if (stock_index > 0) then + ! Check whether this stock is available from this routine. + + ! No stocks from this routine are being checked yet. Return 0. + return + endif ; endif + + do m=1,CS%ntr + call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="MARBL_tracers_stock") + units(m) = trim(units(m))//" kg" + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tracer_data(m)%tr(:,:,:), on_PE_only=.true.) + enddo + MARBL_tracers_stock = CS%ntr + +end function MARBL_tracers_stock + +!> This subroutine extracts the surface fields from this tracer package that +!! are to be shared with the atmosphere in coupled configurations. +subroutine MARBL_tracers_surface_state(sfc_state, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(surface), intent(inout) :: sfc_state !< A structure containing fields that + !! describe the surface state of the ocean. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(MARBL_tracers_CS), pointer :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + + ! Local variables + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + if (.not.associated(CS)) return + + if (allocated(sfc_state%fco2)) then + do j=js,je ; do i=is,ie + ! 44e-6 converts mmol/m^2/s (positive down) to kg CO2/m^2/s (positive down) + sfc_state%fco2(i,j) = US%kg_m2s_to_RZ_T * (44.0e-6 * CS%SFO(i,j,CS%flux_co2_ind)) + enddo ; enddo + endif + +end subroutine MARBL_tracers_surface_state + +!> Copy the requested interior tendency output field into an array. +subroutine MARBL_tracers_get(name, G, GV, array, CS) + + character(len=*), intent(in) :: name !< Name of requested tracer. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: array !< Array filled by this routine. + type(MARBL_tracers_CS), pointer :: CS !< Pointer to the control structure for this module. + + character(len=128), parameter :: sub_name = 'MARBL_tracers_get' + character(len=128) :: log_message + + array(:,:,:) = 0.0 + select case(trim(name)) + case ('Chl') + array(:,:,:) = CS%ITO(:,:,:,CS%total_Chl_ind) + case DEFAULT + write(log_message, "(3A)") "'", trim(name), & + "' is not a valid interior tendency output field name" + call MOM_error(FATAL, log_message) + end select + +end subroutine MARBL_tracers_get + +!> Clean up any allocated memory after the run. +subroutine MARBL_tracers_end(CS) + type(MARBL_tracers_CS), pointer, intent(inout) :: CS !< The control structure returned by a previous + !! call to register_MARBL_tracers. + + integer :: m + + call print_marbl_log(MARBL_instances%StatusLog) + call MARBL_instances%StatusLog%erase() + call MARBL_instances%shutdown() + ! TODO: print MARBL timers to stdout as well + + if (associated(CS)) then + if (allocated(CS%tracer_data)) then + do m=1,CS%ntr + if (associated(CS%tracer_data(m)%tr)) deallocate(CS%tracer_data(m)%tr) + enddo + deallocate(CS%tracer_data) + endif + if (allocated(CS%ind_tr)) deallocate(CS%ind_tr) + if (allocated(CS%id_surface_flux_out)) deallocate(CS%id_surface_flux_out) + if (allocated(CS%interior_tendency_out)) deallocate(CS%interior_tendency_out) + if (allocated(CS%interior_tendency_out_zint)) deallocate(CS%interior_tendency_out_zint) + if (allocated(CS%interior_tendency_out_zint_100m)) & + deallocate(CS%interior_tendency_out_zint_100m) + if (allocated(CS%fracr_cat_id)) deallocate(CS%fracr_cat_id) + if (allocated(CS%qsw_cat_id)) deallocate(CS%qsw_cat_id) + if (allocated(CS%STF)) deallocate(CS%STF) + if (allocated(CS%RIV_FLUXES)) deallocate(CS%RIV_FLUXES) + if (allocated(CS%SFO)) deallocate(CS%SFO) + if (allocated(CS%tracer_restoring_ind)) deallocate(CS%tracer_restoring_ind) + if (allocated(CS%tracer_I_tau_ind)) deallocate(CS%tracer_I_tau_ind) + if (allocated(CS%fesedflux_in)) deallocate(CS%fesedflux_in) + if (allocated(CS%feventflux_in)) deallocate(CS%feventflux_in) + if (allocated(CS%I_tau)) deallocate(CS%I_tau) + deallocate(CS) + endif +end subroutine MARBL_tracers_end + +subroutine set_riv_flux_tracer_inds(CS) + + type(MARBL_tracers_CS), pointer, intent(inout) :: CS !< The MARBL tracers control structure + + character(len=256) :: log_message + character(len=48) :: name ! A variable's name in a NetCDF file. + integer :: m + + ! Initialize tracers from file (unless they were initialized by restart file) + ! Also save indices of tracers that have river fluxes + CS%tracer_inds%no3_ind = 0 + CS%tracer_inds%po4_ind = 0 + CS%tracer_inds%don_ind = 0 + CS%tracer_inds%donr_ind = 0 + CS%tracer_inds%dop_ind = 0 + CS%tracer_inds%dopr_ind = 0 + CS%tracer_inds%sio3_ind = 0 + CS%tracer_inds%fe_ind = 0 + CS%tracer_inds%doc_ind = 0 + CS%tracer_inds%docr_ind = 0 + CS%tracer_inds%alk_ind = 0 + CS%tracer_inds%alk_alt_co2_ind = 0 + CS%tracer_inds%dic_ind = 0 + CS%tracer_inds%dic_alt_co2_ind = 0 + do m=1,CS%ntr + name = MARBL_instances%tracer_metadata(m)%short_name + if (trim(name) == "NO3") then + CS%tracer_inds%no3_ind = m + elseif (trim(name) == "PO4") then + CS%tracer_inds%po4_ind = m + elseif (trim(name) == "DON") then + CS%tracer_inds%don_ind = m + elseif (trim(name) == "DONr") then + CS%tracer_inds%donr_ind = m + elseif (trim(name) == "DOP") then + CS%tracer_inds%dop_ind = m + elseif (trim(name) == "DOPr") then + CS%tracer_inds%dopr_ind = m + elseif (trim(name) == "SiO3") then + CS%tracer_inds%sio3_ind = m + elseif (trim(name) == "Fe") then + CS%tracer_inds%fe_ind = m + elseif (trim(name) == "DOC") then + CS%tracer_inds%doc_ind = m + elseif (trim(name) == "DOCr") then + CS%tracer_inds%docr_ind = m + elseif (trim(name) == "ALK") then + CS%tracer_inds%alk_ind = m + elseif (trim(name) == "ALK_ALT_CO2") then + CS%tracer_inds%alk_alt_co2_ind = m + elseif (trim(name) == "DIC") then + CS%tracer_inds%dic_ind = m + elseif (trim(name) == "DIC_ALT_CO2") then + CS%tracer_inds%dic_alt_co2_ind = m + endif + enddo + + ! Log indices for each tracer to ensure we set them all correctly + write(log_message, "(A,I0)") "NO3 index: ", CS%tracer_inds%no3_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "PO4 index: ", CS%tracer_inds%po4_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DON index: ", CS%tracer_inds%don_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DONr index: ", CS%tracer_inds%donr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOP index: ", CS%tracer_inds%dop_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOPr index: ", CS%tracer_inds%dopr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "SiO3 index: ", CS%tracer_inds%sio3_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "Fe index: ", CS%tracer_inds%fe_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOC index: ", CS%tracer_inds%doc_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DOCr index: ", CS%tracer_inds%docr_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "ALK index: ", CS%tracer_inds%alk_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "ALK_ALT_CO2 index: ", CS%tracer_inds%alk_alt_co2_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DIC index: ", CS%tracer_inds%dic_ind + call MOM_error(NOTE, log_message) + write(log_message, "(A,I0)") "DIC_ALT_CO2 index: ", CS%tracer_inds%dic_alt_co2_ind + call MOM_error(NOTE, log_message) + +end subroutine set_riv_flux_tracer_inds + +! TODO: some log messages come from a specific grid point, and this routine +! needs to include the location in the preamble +!> This subroutine writes the contents of the MARBL log using MOM_error(NOTE, ...). +subroutine print_marbl_log(log_to_print, G, i, j) + + use marbl_logging, only : marbl_status_log_entry_type + use marbl_logging, only : marbl_log_type + use MOM_coms, only : PE_here + + class(marbl_log_type), intent(in) :: log_to_print !< MARBL log to include in MOM6 logfile + type(ocean_grid_type), optional, intent(in) :: G !< The ocean's grid structure + integer, optional, intent(in) :: i !< i of (i,j) index of column providing the log + integer, optional, intent(in) :: j !< j of (i,j) index of column providing the log + + character(len=*), parameter :: subname = 'MARBL_tracers:print_marbl_log' + character(len=256) :: message_prefix, message_location, log_message + type(marbl_status_log_entry_type), pointer :: tmp + integer :: msg_lev, elem_old + + ! elem_old is used to keep track of whether all messages are coming from the same point + elem_old = -1 + write(message_prefix, "(A,I0,A)") '(Task ', PE_here(), ')' + + tmp => log_to_print%FullLog + do while (associated(tmp)) + ! 1) Do I need to write this message? Yes, if all tasks should write this + ! or if I am master_task + if ((.not. tmp%lonly_master_writes) .or. is_root_PE()) then + ! 2) Print message location? (only if ElementInd changed and is positive; requires G) + if ((present(G)) .and. (tmp%ElementInd .ne. elem_old)) then + if (tmp%ElementInd .gt. 0) then + if (present(i) .and. present(j)) then + write(message_location, "(A,F8.3,A,F7.3,A,I0,A,I0,A,I0)") & + 'Message from (lon, lat) (', G%geoLonT(i,j), ', ', G%geoLatT(i,j), & + '), which is global (i,j) (', i + G%HI%idg_offset, ', ', j + G%HI%jdg_offset, & + '). Level: ', tmp%ElementInd + else + write(message_location, "(A)") "Grid cell responsible for message is unknown" + endif ! i,j present + ! master task does not need prefix + if (is_root_PE()) then + write(log_message, "(A)") trim(message_location) + msg_lev = NOTE + else + write(log_message, "(A,1X,A)") trim(message_prefix), trim(message_location) + msg_lev = WARNING + endif ! print message prefix? + call MOM_error(msg_lev, log_message, all_print=.true.) + endif ! ElementInd > 0 + elem_old = tmp%ElementInd + endif ! ElementInd /= elem_old + + ! 3) Write message from the log + ! master task does not need prefix + if (is_root_PE()) then + write(log_message, "(A)") trim(tmp%LogMessage) + msg_lev = NOTE + else + write(log_message, "(A,1X,A)") trim(message_prefix), trim(tmp%LogMessage) + msg_lev = WARNING + endif ! print message prefix? + call MOM_error(msg_lev, log_message, all_print=.true.) + endif ! write the message? + tmp => tmp%next + enddo + + if (log_to_print%labort_marbl) then + call MOM_error(WARNING, 'ERROR reported from MARBL library', all_print=.true.) + call MOM_error(FATAL, 'Stopping in ' // subname) + endif + +end subroutine print_marbl_log + +!> \namespace MARBL_tracers +!! +!! This module contains the code that is needed to provide +!! the MARBL BGC tracer library with necessary forcings and +!! apply the resulting surface fluxes and tendencies to the +!! requested tracers. + +end module MARBL_tracers diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 5b9af238d6..a81a42b428 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -421,7 +421,7 @@ integer function find_minimum(x, s, e) if (x(i) < minimum) then ! if x(i) less than the min? minimum = x(i) ! Yes, a new minimum found location = i ! record its position - end if + endif enddo find_minimum = location ! return the position end function find_minimum diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index fab7da3917..caa2d10a04 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -16,7 +16,7 @@ module MOM_tracer_Z_init #include -public tracer_Z_init, tracer_Z_init_array, determine_temperature +public tracer_Z_init, read_Z_edges, tracer_Z_init_array, determine_temperature ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index c8ce2f5f75..ef80f9d23c 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -38,6 +38,10 @@ module MOM_tracer_flow_control use ideal_age_example, only : register_ideal_age_tracer, initialize_ideal_age_tracer use ideal_age_example, only : ideal_age_tracer_column_physics, ideal_age_tracer_surface_state use ideal_age_example, only : ideal_age_stock, ideal_age_example_end, ideal_age_tracer_CS +use MARBL_tracers, only : register_MARBL_tracers, initialize_MARBL_tracers +use MARBL_tracers, only : MARBL_tracers_column_physics, MARBL_tracers_set_forcing +use MARBL_tracers, only : MARBL_tracers_surface_state, MARBL_tracers_get +use MARBL_tracers, only : MARBL_tracers_stock, MARBL_tracers_end, MARBL_tracers_CS use regional_dyes, only : register_dye_tracer, initialize_dye_tracer use regional_dyes, only : dye_tracer_column_physics, dye_tracer_surface_state use regional_dyes, only : dye_stock, regional_dyes_end, dye_tracer_CS @@ -85,6 +89,7 @@ module MOM_tracer_flow_control logical :: use_ISOMIP_tracer = .false. !< If true, use the ISOMPE_tracer package logical :: use_RGC_tracer =.false. !< If true, use the RGC_tracer package logical :: use_ideal_age = .false. !< If true, use the ideal age tracer package + logical :: use_MARBL_tracers = .false. !< If true, use the MARBL tracer package logical :: use_regional_dyes = .false. !< If true, use the regional dyes tracer package logical :: use_oil = .false. !< If true, use the oil tracer package logical :: use_advection_test_tracer = .false. !< If true, use the advection_test_tracer package @@ -95,12 +100,14 @@ module MOM_tracer_flow_control logical :: use_boundary_impulse_tracer = .false. !< If true, use the boundary impulse tracer package logical :: use_dyed_obc_tracer = .false. !< If true, use the dyed OBC tracer package logical :: use_nw2_tracers = .false. !< If true, use the NW2 tracer package + logical :: get_chl_from_MARBL = .false. !< If true, use the MARBL-provided Chl for shortwave penetration !>@{ Pointers to the control strucures for the tracer packages type(USER_tracer_example_CS), pointer :: USER_tracer_example_CSp => NULL() type(DOME_tracer_CS), pointer :: DOME_tracer_CSp => NULL() type(ISOMIP_tracer_CS), pointer :: ISOMIP_tracer_CSp => NULL() type(RGC_tracer_CS), pointer :: RGC_tracer_CSp => NULL() type(ideal_age_tracer_CS), pointer :: ideal_age_tracer_CSp => NULL() + type(MARBL_tracers_CS), pointer :: MARBL_tracers_CSp => NULL() type(dye_tracer_CS), pointer :: dye_tracer_CSp => NULL() type(oil_tracer_CS), pointer :: oil_tracer_CSp => NULL() type(advection_test_tracer_CS), pointer :: advection_test_tracer_CSp => NULL() @@ -193,6 +200,9 @@ subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", CS%use_ideal_age, & "If true, use the ideal_age_example tracer package.", & default=.false.) + call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + "If true, use the MARBL tracer package.", & + default=.false.) call get_param(param_file, mdl, "USE_REGIONAL_DYES", CS%use_regional_dyes, & "If true, use the regional_dyes tracer package.", & default=.false.) @@ -243,6 +253,9 @@ subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) if (CS%use_ideal_age) CS%use_ideal_age = & register_ideal_age_tracer(G%HI, GV, param_file, CS%ideal_age_tracer_CSp, & tr_Reg, restart_CS) + if (CS%use_MARBL_tracers) CS%use_MARBL_tracers = & + register_MARBL_tracers(G%HI, GV, US, param_file, CS%MARBL_tracers_CSp, & + tr_Reg, restart_CS, CS%get_chl_from_MARBL) if (CS%use_regional_dyes) CS%use_regional_dyes = & register_dye_tracer(G%HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) @@ -327,6 +340,9 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag if (CS%use_ideal_age) & call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & sponge_CSp) + if (CS%use_MARBL_tracers) & + call initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag, OBC, CS%MARBL_tracers_CSp, & + sponge_CSp) if (CS%use_regional_dyes) & call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv) if (CS%use_oil) & @@ -386,7 +402,9 @@ subroutine get_chl_from_model(Chl_array, G, GV, CS) type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. - if (CS%use_MOM_generic_tracer) then + if (CS%get_chl_from_MARBL) then + call MARBL_tracers_get('Chl', G, GV, Chl_array, CS%MARBL_tracers_CSp) + elseif (CS%use_MOM_generic_tracer) then call MOM_generic_tracer_get('chl', 'field', Chl_array, CS%MOM_generic_tracer_CSp) else call MOM_error(FATAL, "get_chl_from_model was called in a configuration "// & @@ -424,6 +442,9 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G call CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, & CS%CFC_cap_CSp) + if (CS%use_MARBL_tracers) & + call MARBL_tracers_set_forcing(day_start, G, CS%MARBL_tracers_CSp) + end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. @@ -494,6 +515,13 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, & Hbl=Hml) + if (CS%use_MARBL_tracers) & + call MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, tv, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans, & + evap_CFL_limit=evap_CFL_limit, & + minimum_forcing_depth=minimum_forcing_depth) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, tv, CS%dye_tracer_CSp, & @@ -570,6 +598,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, tv, CS%ideal_age_tracer_CSp, Hbl=Hml) + if (CS%use_MARBL_tracers) & + call MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, tv, & + KPP_CSp=KPP_CSp, & + nonLocalTrans=nonLocalTrans) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, tv, CS%dye_tracer_CSp) @@ -691,6 +724,12 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif + if (CS%use_MARBL_tracers) then + ns = MARBL_tracers_stock(h, values_EFP, G, GV, CS%MARBL_tracers_CSp, & + names, units, stock_index) + call store_stocks("MARBL_tracers", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + endif if (CS%use_regional_dyes) then ns = dye_stock(h, values_EFP, G, GV, CS%dye_tracer_CSp, names, units, stock_index) call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & @@ -844,6 +883,8 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, US, CS) call ISOMIP_tracer_surface_state(sfc_state, h, G, GV, CS%ISOMIP_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_surface_state(sfc_state, h, G, GV, CS%ideal_age_tracer_CSp) + if (CS%use_MARBL_tracers) & + call MARBL_tracers_surface_state(sfc_state, G, US, CS%MARBL_tracers_CSp) if (CS%use_regional_dyes) & call dye_tracer_surface_state(sfc_state, h, G, GV, CS%dye_tracer_CSp) if (CS%use_oil) & @@ -867,6 +908,7 @@ subroutine tracer_flow_control_end(CS) if (CS%use_ISOMIP_tracer) call ISOMIP_tracer_end(CS%ISOMIP_tracer_CSp) if (CS%use_RGC_tracer) call RGC_tracer_end(CS%RGC_tracer_CSp) if (CS%use_ideal_age) call ideal_age_example_end(CS%ideal_age_tracer_CSp) + if (CS%use_MARBL_tracers) call MARBL_tracers_end(CS%MARBL_tracers_CSp) if (CS%use_regional_dyes) call regional_dyes_end(CS%dye_tracer_CSp) if (CS%use_oil) call oil_tracer_end(CS%oil_tracer_CSp) if (CS%use_advection_test_tracer) call advection_test_tracer_end(CS%advection_test_tracer_CSp) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c01419f3f8..c7d11b6030 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -390,6 +390,16 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') endif + Tr%id_zint = register_diag_field("ocean_model", trim(shortnm)//"_zint", & + diag%axesT1, Time, & + "Thickness-weighted integral of " // trim(longname), & + trim(units) // " m") + Tr%id_zint_100m = register_diag_field("ocean_model", trim(shortnm)//"_zint_100m", & + diag%axesT1, Time, & + "Thickness-weighted integral of "// trim(longname) // " over top 100m", & + trim(units) // " m") + Tr%id_surf = register_diag_field("ocean_model", trim(shortnm)//"_SURF", & + diag%axesT1, Time, "Surface values of "// trim(longname), trim(units)) if (Tr%id_adx > 0) call safe_alloc_ptr(Tr%ad_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) @@ -592,7 +602,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u conversion = GV%H_to_kg_m2 else conversion = Tr%conv_scale - end if + endif ! We actually want conversion=Tr%conv_scale for all tracers, but introducing the local variable ! 'conversion' and setting it to GV%H_to_kg_m2 instead of 0.001*GV%H_to_kg_m2 for salt tracers ! keeps changes introduced by this refactoring limited to round-off level; as it turns out, @@ -716,12 +726,42 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output - integer :: i, j, k, is, ie, js, je, nz, m - real :: work2d(SZI_(G),SZJ_(G)) + integer :: i, j, k, is, ie, js, je, nz, m, khi + real :: frac_under_100m(SZI_(G),SZJ_(G),SZK_(GV)) + real :: work2d(SZI_(G),SZJ_(G)), ztop(SZI_(G),SZJ_(G)), zbot(SZI_(G),SZJ_(G)) type(tracer_type), pointer :: Tr=>NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + ! If any tracers are posting 100m vertical integrals, compute weights + frac_under_100m(:,:,:) = 0.0 + ! khi will be the largest layer index corresponding where ztop < 100m and ztop >= 100m + ! in any column (we can reduce computation of 100m integrals by only looping through khi + ! rather than GV%ke) + khi = 0 + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) + if (Tr%id_zint_100m > 0) then + zbot(:,:) = 0.0 + do k=1, nz + do j=js,je ; do i=is,ie + ztop(i,j) = zbot(i,j) + zbot(i,j) = ztop(i,j) + h_diag(i,j,k)*GV%H_to_m + if (zbot(i,j) <= 100.0) then + frac_under_100m(i,j,k) = 1.0 + elseif (ztop(i,j) < 100.0) then + frac_under_100m(i,j,k) = (100.0 - ztop(i,j)) / (zbot(i,j) - ztop(i,j)) + else + frac_under_100m(i,j,k) = 0.0 + endif + ! frac_under_100m(i,j,k) = max(0, min(1.0, (100.0 - ztop(i,j)) / (zbot(i,j) - ztop(i,j)))) + enddo ; enddo + if (any(frac_under_100m(:,:,k) > 0)) khi = k + enddo + exit + endif + endif; enddo + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then Tr => Reg%Tr(m) if (Tr%id_tr_post_horzn> 0) call post_data(Tr%id_tr_post_horzn, Tr%t, diag) @@ -741,6 +781,28 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) enddo ; enddo ; enddo call post_data(Tr%id_adv_xy_2d, work2d, diag) endif + + ! A few diagnostics introduce with MARBL driver + ! Compute full-depth vertical integral + if (Tr%id_zint > 0) then + work2d(:,:) = 0.0 + do k=1,nz ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + (h_diag(i,j,k)*GV%H_to_m)*tr%t(i,j,k) + enddo ; enddo ; enddo + call post_data(Tr%id_zint, work2d, diag) + endif + + ! Compute 100m vertical integral + if (Tr%id_zint_100m > 0) then + work2d(:,:) = 0.0 + do k=1,khi ; do j=js,je ; do i=is,ie + work2d(i,j) = work2d(i,j) + frac_under_100m(i,j,k)*((h_diag(i,j,k)*GV%H_to_m)*tr%t(i,j,k)) + enddo ; enddo ; enddo + call post_data(Tr%id_zint_100m, work2d, diag) + endif + + ! Surface values of tracers + if (Tr%id_SURF > 0) call post_data(Tr%id_SURF, Tr%t(:,:,1), diag) endif ; enddo end subroutine post_tracer_transport_diagnostics diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index bdae8bcee9..55326a0b1b 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -111,6 +111,7 @@ module MOM_tracer_types integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 + integer :: id_zint = -1, id_zint_100m = -1, id_surf = -1 integer :: id_net_surfflux = -1, id_NLT_tendency = -1, id_NLT_budget = -1 !>@} end type tracer_type From 7afbb6df3dedbda27854fed446fba9e884dd711d Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 5 Aug 2024 16:43:47 -0600 Subject: [PATCH 17/31] Add missing missing_scale argument to read_Z_edges calls The argument missing_scale was missing in the calls to read_Z_edges. This patch adds missing_scale=1.0 to these calls. In the future, we might want to consider adding an option to pass a factor to scale the output tracers from the units in the input file. --- src/tracer/MARBL_tracers.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index 9c856fef85..baf7931e51 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -721,7 +721,8 @@ function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, ! Set up array for thicknesses in restoring file call read_Z_edges(CS%restoring_file, "PO4", CS%restoring_z_edges, CS%restoring_nz, & - restoring_has_edges, restoring_use_missing, restoring_missing, scale=US%m_to_Z) + restoring_has_edges, restoring_use_missing, restoring_missing, scale=US%m_to_Z, & + missing_scale=1.0) allocate(CS%restoring_dz(CS%restoring_nz)) do k=CS%restoring_nz,1,-1 kbot = k + 1 ! level k is between z(k) and z(k+1) @@ -740,7 +741,8 @@ function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, ! Set up array for thicknesses in restoring timescale file call read_Z_edges(CS%restoring_I_tau_file, CS%restoring_I_tau_var_name, CS%restoring_timescale_z_edges, & CS%restoring_timescale_nz, restoring_timescale_has_edges, & - restoring_timescale_use_missing, restoring_timescale_missing, scale=US%m_to_Z) + restoring_timescale_use_missing, restoring_timescale_missing, scale=US%m_to_Z, & + missing_scale=1.0) allocate(CS%restoring_timescale_dz(CS%restoring_timescale_nz)) do k=CS%restoring_timescale_nz,1,-1 kbot = k + 1 ! level k is between z(k) and z(k+1) @@ -1001,7 +1003,8 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag ! -- note: read_Z_edges treats depth as positive UP => 0 at surface, negative at depth fesedflux_use_missing = .false. call read_Z_edges(CS%fesedflux_file, "FESEDFLUXIN", CS%fesedflux_z_edges, CS%fesedflux_nz, & - fesedflux_has_edges, fesedflux_use_missing, fesedflux_missing, scale=US%m_to_Z) + fesedflux_has_edges, fesedflux_use_missing, fesedflux_missing, scale=US%m_to_Z, & + missing_scale=1.0) ! (2) Allocate memory for fesedflux and feventflux allocate(CS%fesedflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) From 225c0d8290ea94bbe5490e6686fef2b74c7a6b8f Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Wed, 7 Aug 2024 13:03:38 -0600 Subject: [PATCH 18/31] remove incorrect comma in write statements (#293) --- src/framework/MOM_domains.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 22226d3b85..e911bb75ed 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -677,10 +677,10 @@ subroutine write_auto_mask_file(mask_table, layout, npes, filename) true_num_masked_blocks = layout(1) * layout(2) - npes call open_ASCII_file(file_ascii, trim(filename), action=WRITEONLY_FILE) - write(file_ascii, '(I0)'), true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), layout(1), layout(2) + write(file_ascii, '(I0)') true_num_masked_blocks + write(file_ascii, '(I0,",",I0)') layout(1), layout(2) do p = 1, true_num_masked_blocks - write(file_ascii, '(I0,",",I0)'), mask_table(p,1), mask_table(p,2) + write(file_ascii, '(I0,",",I0)') mask_table(p,1), mask_table(p,2) enddo call close_file(file_ascii) end subroutine write_auto_mask_file From 5904666efe252907b4c0577dc7318708fa0d9dac Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 9 Aug 2024 15:54:12 -0600 Subject: [PATCH 19/31] Options to enforce KHTR_MIN and KHTH_MIN in the whole water column and fix naming inconsistency (#294) * Rename KhTh_use_ebt_struct to KhTr_use_ebt_struct The parameter KHTR_USE_EBT_STRUCT was introduced with an incorrect variable name within the local control structure. The variable was named KhTh_use_ebt_struct, indicating thickness diffusivity, instead of the correct KhTr_use_ebt_struct, which indicates tracer diffusivity. This commit rectifies the naming inconsistency. * Option to apply KHTR_MIN in the whole water column This commit introduces a new parameter, FULL_DEPTH_KHTR_MIN, which enforces a user-specified minimum diffusivity (KHTR_MIN) to be applied throughout the entire water column, instead of only at the surface. This option is available only when KHTR_USE_EBT_STRUCT=True and KHTR_MIN > 0. * Option to apply KHTH_MIN in the whole water column This commit introduces a new parameter, FULL_DEPTH_KHTH_MIN, which enforces a user-specified minimum diffusivity (KHTH_MIN) to be applied throughout the entire water column instead of only at the surface. This option is available only when KHTH_USE_EBT_STRUCT=True and KHTH_MIN > 0. --- .../lateral/MOM_thickness_diffuse.F90 | 52 ++++++++++++--- src/tracer/MOM_tracer_hor_diff.F90 | 63 ++++++++++++++----- 2 files changed, 89 insertions(+), 26 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 9258f4bae3..458da9fb48 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -49,6 +49,9 @@ module MOM_thickness_diffuse real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: thickness_diffuse !< If true, interfaces heights are diffused. + logical :: full_depth_khth_min !< If true, KHTH_MIN is enforced throughout the whole water column. + !! Otherwise, KHTH_MIN is only enforced at the surface. This parameter + !! is only available when KHTH_USE_EBT_STRUCT=True and KHTH_MIN>0. logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of !! Ferrari et al., 2010, which effectively emphasizes !! graver vertical modes by smoothing in the vertical. @@ -301,10 +304,18 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo if (khth_use_ebt_struct) then - !$OMP do - do K=2,nz+1 ; do j=js,je ; do I=is-1,ie - KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) - enddo ; enddo ; enddo + if (CS%full_depth_khth_min) then + !$OMP do + do K=2,nz+1 ; do j=js,je ; do I=is-1,ie + KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + KH_u(I,j,K) = max(KH_u(I,j,K), CS%Khth_Min) + enddo ; enddo ; enddo + else + !$OMP do + do K=2,nz+1 ; do j=js,je ; do I=is-1,ie + KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo ; enddo ; enddo + endif else !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie @@ -397,10 +408,18 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (khth_use_ebt_struct) then - !$OMP do - do K=2,nz+1 ; do J=js-1,je ; do i=is,ie - KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) - enddo ; enddo ; enddo + if (CS%full_depth_khth_min) then + !$OMP do + do K=2,nz+1 ; do J=js-1,je ; do i=is,ie + KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + KH_v(i,J,K) = max(KH_v(i,J,K), CS%Khth_Min) + enddo ; enddo ; enddo + else + !$OMP do + do K=2,nz+1 ; do J=js-1,je ; do i=is,ie + KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo ; enddo ; enddo + endif else !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie @@ -2169,7 +2188,11 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! rotation [nondim]. real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] - integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: khth_use_ebt_struct ! If true, uses the equivalent barotropic structure + ! as the vertical structure of thickness diffusivity. + ! Used to determine if FULL_DEPTH_KHTH_MIN should be + ! available. + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: i, j CS%initialized = .true. @@ -2215,6 +2238,17 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & "The minimum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTH_USE_EBT_STRUCT", khth_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of thickness diffusivity.",& + default=.false., do_not_log=.true.) + if (khth_use_ebt_struct .and. CS%KHTH_Min>0.0) then + call get_param(param_file, mdl, "FULL_DEPTH_KHTH_MIN", CS%full_depth_khth_min, & + "If true, KHTH_MIN is enforced throughout the whole water column. "//& + "Otherwise, KHTH_MIN is only enforced at the surface. This parameter "//& + "is only available when KHTH_USE_EBT_STRUCT=True and KHTH_MIN>0.", & + default=.false.) + endif call get_param(param_file, mdl, "KHTH_MAX", CS%KHTH_Max, & "The maximum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 2b1530e94d..0825edf6b3 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -52,8 +52,11 @@ module MOM_tracer_hor_diff real :: max_diff_CFL !< If positive, locally limit the along-isopycnal !! tracer diffusivity to keep the diffusive CFL !! locally at or below this value [nondim]. - logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + logical :: KhTr_use_ebt_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of tracer diffusivity. + logical :: full_depth_khtr_min !< If true, KHTR_MIN is enforced throughout the whole water column. + !! Otherwise, KHTR_MIN is only enforced at the surface. This parameter + !! is only available when KHTR_USE_EBT_STRUCT=True and KHTR_MIN>0. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion @@ -422,21 +425,40 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then - do K=2,nz+1 - do J=js-1,je - do i=is,ie - Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + if (CS%KhTr_use_ebt_struct) then + if (CS%full_depth_khtr_min) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + Coef_y(i,J,K) = max(Coef_y(i,J,K), CS%KhTr_min) + enddo enddo enddo - enddo - do k=2,nz+1 - do j=js,je - do I=is-1,ie - Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + Coef_x(I,j,K) = max(Coef_x(I,j,K), CS%KhTr_min) + enddo enddo enddo - enddo + else + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif endif do itt=1,num_itts @@ -478,7 +500,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_ebt_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie @@ -605,7 +627,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do j=js,je ; do I=is-1,ie Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_ebt_struct) then do K=2,nz+1 do j=js,je do I=is-1,ie @@ -621,7 +643,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ do J=js-1,je ; do i=is,ie Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_ebt_struct) then do K=2,nz+1 do J=js-1,je do i=is,ie @@ -647,7 +669,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) - if (CS%KhTh_use_ebt_struct) then + if (CS%KhTr_use_ebt_struct) then do K=2,nz+1 Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & (Kh_v(i,J-1,1)+Kh_v(i,J,1))) @@ -1630,7 +1652,7 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR", CS%KhTr, & "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) - call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTr_use_ebt_struct, & "If true, uses the equivalent barotropic structure "//& "as the vertical structure of the tracer diffusivity.",& default=.false.) @@ -1642,6 +1664,13 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR_MIN", CS%KhTr_Min, & "The minimum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + if (CS%KhTr_use_ebt_struct .and. CS%KhTr_Min > 0.0) then + call get_param(param_file, mdl, "FULL_DEPTH_KHTR_MIN", CS%full_depth_khtr_min, & + "If true, KHTR_MIN is enforced throughout the whole water column. "//& + "Otherwise, KHTR_MIN is only enforced at the surface. This parameter "//& + "is only available when KHTR_USE_EBT_STRUCT=True and KHTR_MIN>0.", & + default=.false.) + endif call get_param(param_file, mdl, "KHTR_MAX", CS%KhTr_Max, & "The maximum along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) From 4acea916ffe8c0b53c420b4d8e793bb225f7b9a8 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Wed, 28 Aug 2024 16:06:48 -0600 Subject: [PATCH 20/31] MARBL: convert salt_flux to tracer flux and add to STF This is done for DIC, ALK, and related tracers. This mimics uptake and release of these tracers by sea ice. --- src/tracer/MARBL_tracers.F90 | 95 +++++++++++++++++++++++++++++++++++- 1 file changed, 94 insertions(+), 1 deletion(-) diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index baf7931e51..93c6988130 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -82,6 +82,8 @@ module MARBL_tracers integer :: alk_alt_co2_ind !< ALK_ALT_CO2 index integer :: dic_ind !< DIC index integer :: dic_alt_co2_ind !< DIC_ALT_CO2 index + integer :: abio_dic_ind !< ABIO_DIC index + integer :: abio_di14c_ind !< ABIO_DI14C index end type tracer_ind_type !> MOM needs to store some information about saved_state; besides providing these @@ -183,6 +185,7 @@ module MARBL_tracers !! because we already copy data into CS%STF; latter requires copying data and indices !! so currently using temp_MARBL_diag for that. integer, allocatable :: id_surface_flux_out(:) !< register_diag indices for surface_flux output + integer, allocatable :: id_surface_flux_from_salt_flux(:) !< register_diag indices for surface_flux from salt_flux type(temp_MARBL_diag), allocatable :: interior_tendency_out(:) !< collect interior tendencies for diagnostic output type(temp_MARBL_diag), allocatable :: interior_tendency_out_zint(:) !< vertical integral of interior tendencies !! (full column) @@ -192,6 +195,9 @@ module MARBL_tracers integer, allocatable :: fracr_cat_id(:) !< register_diag index for per-category ice fraction integer, allocatable :: qsw_cat_id(:) !< register_diag index for per-category shortwave + real :: DIC_salt_ratio !< ratio to convert salt surface flux to DIC surface flux [conc ppt-1] + real :: ALK_salt_ratio !< ratio to convert salt surface flux to ALK surface flux [conc ppt-1] + real, allocatable :: STF(:,:,:) !< surface fluxes returned from MARBL to use in tracer_vertdiff !! (dims: i, j, tracer) [conc Z T-1 ~> conc m s-1] real, allocatable :: SFO(:,:,:) !< surface flux output returned from MARBL for use in GCM @@ -703,7 +709,14 @@ function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, call log_param(param_file, mdl, "INPUTDIR/D14C_FILE", CS%d14c_dataset(m)%file_name) endif enddo -endif + endif + + call get_param(param_file, mdl, "DIC_SALT_RATIO", CS%DIC_salt_ratio, & + "Ratio to convert salt surface flux to DIC surface flux", units="conc ppt-1", & + default=64.0) + call get_param(param_file, mdl, "ALK_SALT_RATIO", CS%ALK_salt_ratio, & + "Ratio to convert salt surface flux to ALK surface flux", units="conc ppt-1", & + default=70.0) ! ** Tracer Restoring call get_param(param_file, mdl, "MARBL_TRACER_RESTORING_SOURCE", CS%restoring_source, & @@ -858,6 +871,7 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag ! Register per-tracer diagnostics computed from MARBL surface flux / interior tendency values allocate(CS%id_surface_flux_out(CS%ntr)) + allocate(CS%id_surface_flux_from_salt_flux(CS%ntr)) allocate(CS%interior_tendency_out(CS%ntr)) allocate(CS%interior_tendency_out_zint(CS%ntr)) allocate(CS%interior_tendency_out_zint_100m(CS%ntr)) @@ -869,6 +883,12 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag diag%axesT1, & ! T => tracer grid? 1 => no vertical grid day, trim(longname), trim(units), conversion=US%Z_to_m*US%s_to_T) + write(name, "(2A)") "STF_SALT_", trim(MARBL_instances%tracer_metadata(m)%short_name) + write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Surface Flux from Salt Flux" + CS%id_surface_flux_from_salt_flux(m) = register_diag_field("ocean_model", trim(name), & + diag%axesT1, & ! T => tracer grid? 1 => no vertical grid + day, trim(longname), trim(units), conversion=US%Z_to_m*US%s_to_T) + write(name, "(2A)") "J_", trim(MARBL_instances%tracer_metadata(m)%short_name) write(longname, "(2A)") trim(MARBL_instances%tracer_metadata(m)%long_name), " Source Sink Term" write(units, "(2A)") trim(MARBL_instances%tracer_metadata(m)%units), "/s" @@ -1239,6 +1259,10 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, ! Local variables character(len=256) :: log_message + real, dimension(SZI_(G),SZJ_(G)) :: net_salt_rate !< Surface salt flux into the ocean + !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: flux_from_salt_flux !< Surface tracer flux from salt flux + !! [conc Z T-1 ~> conc m s-1]. real, dimension(SZI_(G),SZJ_(G)) :: ref_mask ! Mask for 2D MARBL diags using ref_depth real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -1368,6 +1392,69 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, enddo enddo + ! convert salt flux to tracer fluxes and add to STF + do j=js,je ; do i=is,ie + net_salt_rate(i,j) = (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j)) * GV%RZ_to_H + enddo ; enddo + + ! DIC related tracers + do j=js,je ; do i=is,ie + flux_from_salt_flux(i,j) = (CS%DIC_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) + enddo ; enddo + m = CS%tracer_inds%dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%dic_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_di14c_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + + ! ALK related tracers + do j=js,je ; do i=is,ie + flux_from_salt_flux(i,j) = (CS%ALK_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) + enddo ; enddo + m = CS%tracer_inds%alk_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%alk_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + if (CS%debug) then do m=1,CS%ntr call hchksum(CS%STF(:,:,m), & @@ -2061,6 +2148,8 @@ subroutine set_riv_flux_tracer_inds(CS) CS%tracer_inds%alk_alt_co2_ind = 0 CS%tracer_inds%dic_ind = 0 CS%tracer_inds%dic_alt_co2_ind = 0 + CS%tracer_inds%abio_dic_ind = 0 + CS%tracer_inds%abio_di14c_ind = 0 do m=1,CS%ntr name = MARBL_instances%tracer_metadata(m)%short_name if (trim(name) == "NO3") then @@ -2091,6 +2180,10 @@ subroutine set_riv_flux_tracer_inds(CS) CS%tracer_inds%dic_ind = m elseif (trim(name) == "DIC_ALT_CO2") then CS%tracer_inds%dic_alt_co2_ind = m + elseif (trim(name) == "ABIO_DIC") then + CS%tracer_inds%abio_dic_ind = m + elseif (trim(name) == "ABIO_DI14C") then + CS%tracer_inds%abio_di14c_ind = m endif enddo From 621107b9999b4af52c1887e99b84e8a1ec441415 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Fri, 30 Aug 2024 09:34:21 -0600 Subject: [PATCH 21/31] Modify NUOPC cap to accept separate glc runoff fluxes (#288) * Modify NUOPC cap to accept separate glc runoff fluxes * (1/2) Add separate fluxes for glc runoff. (2/2) Add heat content fields for lrunoff_glc and frunoff_glc. * fix merge bugs and add more glc runoff diags * enable glc runoff flux only if use_glc_runoff is present * add ALLOW_GLC_RUNOFF_DIAGNOSTICS param to control whether to allow separate glacier runoff fluxes. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 40 +++ .../drivers/nuopc_cap/mom_cap_methods.F90 | 33 ++ .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 47 ++- src/core/MOM_forcing_type.F90 | 294 +++++++++++++++--- src/diagnostics/MOM_sum_output.F90 | 4 +- .../vertical/MOM_bulk_mixed_layer.F90 | 6 +- .../vertical/MOM_diabatic_aux.F90 | 3 +- 7 files changed, 370 insertions(+), 57 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index d0ee3aad87..5f4b2e19ca 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -737,6 +737,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) Ice_ocean_boundary% hrofi (isc:iec,jsc:jec), & Ice_ocean_boundary% hevap (isc:iec,jsc:jec), & Ice_ocean_boundary% hcond (isc:iec,jsc:jec), & + Ice_ocean_boundary% lrunoff_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% frunoff_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofl_glc (isc:iec,jsc:jec), & + Ice_ocean_boundary% hrofi_glc (isc:iec,jsc:jec), & source=0.0) ! Needed for MARBL @@ -797,6 +801,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_pslv" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff + if (cesm_coupled) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Forr_rofl_glc" , "will provide") !-> liquid glc runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Forr_rofi_glc" , "will provide") !-> frozen glc runoff + endif call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_meltw" , "will provide") @@ -808,6 +816,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hcond" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl" , "will provide") call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi" , "will provide") + if (cesm_coupled) then + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl_glc" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi_glc" , "will provide") + endif if (Ice_ocean_boundary%ice_ncat > 0) then call fld_list_add(fldsToOcn_num, fldsToOcn, "Sf_afracr", "will provide") @@ -2855,6 +2867,34 @@ end subroutine shr_log_setLogUnit !! !! !! +!! Forr_rofl_glc +!! kg m-2 s-1 +!! runoff +!! mass flux of liquid glc runoff +!! +!! +!! +!! Forr_rofi_glc +!! kg m-2 s-1 +!! runoff +!! mass flux of frozen glc runoff +!! +!! +!! +!! Foxx_hrofi_glc +!! W m-2 +!! hrofi_glc +!! heat content (enthalpy) of frozen glc runoff +!! +!! +!! +!! Foxx_hrofl_glc +!! W m-2 +!! hrofl_glc +!! heat content (enthalpy) of liquid glc runoff +!! +!! +!! !! Fioi_salt !! kg m-2 s-1 !! salt_flux diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index d5ec9dc259..bb12dc6092 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -216,6 +216,22 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, isc, iec, jsc, jec, ice_ocean_boundary%frunoff, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! liquid glc runoff + if ( associated(ice_ocean_boundary%lrunoff_glc) ) then + ice_ocean_boundary%lrunoff_glc (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Forr_rofl_glc', & + isc, iec, jsc, jec, ice_ocean_boundary%lrunoff_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! frozen glc runoff + if ( associated(ice_ocean_boundary%frunoff_glc) ) then + ice_ocean_boundary%frunoff_glc (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Forr_rofi_glc', & + isc, iec, jsc, jec, ice_ocean_boundary%frunoff_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + !---- ! Enthalpy terms !---- @@ -256,6 +272,23 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, if (ChkErr(rc,__LINE__,u_FILE_u)) return end if + !---- + ! enthalpy from liquid glc runoff (hrofl_glc) + !---- + if ( associated(ice_ocean_boundary%hrofl_glc) ) then + call state_getimport(importState, 'Foxx_hrofl_glc', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofl_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + + !---- + ! enthalpy from frozen glc runoff (hrofi_glc) + !---- + if ( associated(ice_ocean_boundary%hrofi_glc) ) then + call state_getimport(importState, 'Foxx_hrofi_glc', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofi_glc, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if !---- ! enthalpy from evaporation (hevap) !---- diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 122a9d00ca..9f409a1af9 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -164,6 +164,8 @@ module MOM_surface_forcing_nuopc type, public :: ice_ocean_boundary_type real, pointer, dimension(:,:) :: lrunoff =>NULL() !< liquid runoff [kg/m2/s] real, pointer, dimension(:,:) :: frunoff =>NULL() !< ice runoff [kg/m2/s] + real, pointer, dimension(:,:) :: lrunoff_glc =>NULL() !< liquid glc runoff via rof [kg/m2/s] + real, pointer, dimension(:,:) :: frunoff_glc =>NULL() !< frozen glc runoff via rof [kg/m2/s] real, pointer, dimension(:,:) :: u_flux =>NULL() !< i-direction wind stress [Pa] real, pointer, dimension(:,:) :: v_flux =>NULL() !< j-direction wind stress [Pa] real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W/m2] @@ -183,6 +185,8 @@ module MOM_surface_forcing_nuopc real, pointer, dimension(:,:) :: mass_berg =>NULL() !< mass of icebergs(kg/m2) real, pointer, dimension(:,:) :: hrofl =>NULL() !< heat content from liquid runoff [W/m2] real, pointer, dimension(:,:) :: hrofi =>NULL() !< heat content from frozen runoff [W/m2] + real, pointer, dimension(:,:) :: hrofl_glc =>NULL() !< heat content from liquid glc runoff [W/m2] + real, pointer, dimension(:,:) :: hrofi_glc =>NULL() !< heat content from frozen glc runoff [W/m2] real, pointer, dimension(:,:) :: hrain =>NULL() !< heat content from liquid precipitation [W/m2] real, pointer, dimension(:,:) :: hsnow =>NULL() !< heat content from frozen precipitation [W/m2] real, pointer, dimension(:,:) :: hevap =>NULL() !< heat content from evaporation [W/m2] @@ -494,6 +498,16 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%frunoff(i-i0,j-j0) * G%mask2dT(i,j) endif + ! add liquid glc runoff flux via rof + if (associated(IOB%lrunoff_glc)) then + fluxes%lrunoff_glc(i,j) = kg_m2_s_conversion * IOB%lrunoff_glc(i-i0,j-j0) * G%mask2dT(i,j) + endif + + ! ice glc runoff flux via rof + if (associated(IOB%frunoff_glc)) then + fluxes%frunoff_glc(i,j) = kg_m2_s_conversion * IOB%frunoff_glc(i-i0,j-j0) * G%mask2dT(i,j) + endif + if (associated(IOB%ustar_berg)) & fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) @@ -531,6 +545,13 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion endif + ! notice minus sign since frunoff_glc is positive into the ocean + if (associated(IOB%frunoff_glc)) then + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff_glc(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_glc_diag(i,j) = fluxes%latent_frunoff_glc_diag(i,j) - G%mask2dT(i,j) * & + IOB%frunoff_glc(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + endif if (associated(IOB%q_flux)) then fluxes%latent(i,j) = fluxes%latent(i,j) + & IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor @@ -572,6 +593,12 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (associated(IOB%hcond)) & fluxes%heat_content_cond(i,j) = US%W_m2_to_QRZ_T * IOB%hcond(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofl_glc)) & + fluxes%heat_content_lrunoff_glc(i,j) = US%W_m2_to_QRZ_T * IOB%hrofl_glc(i-i0,j-j0) * G%mask2dT(i,j) + + if (associated(IOB%hrofi_glc)) & + fluxes%heat_content_frunoff_glc(i,j) = US%W_m2_to_QRZ_T * IOB%hrofi_glc(i-i0,j-j0) * G%mask2dT(i,j) endif ! sea ice fraction [nondim] @@ -633,7 +660,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie net_FW(i,j) = US%RZ_T_to_kg_m2s * & (((fluxes%lprec(i,j) + fluxes%fprec(i,j) + fluxes%seaice_melt(i,j)) + & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j))) + & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) + & + fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j))) + & (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) enddo ; enddo @@ -1133,7 +1161,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: new_sim, iceberg_flux_diags, glc_runoff_diags, fix_ustar_gustless_bug logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc @@ -1431,8 +1459,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, "If true, makes available diagnostics of fluxes from icebergs "//& "as seen by MOM6.", default=.false.) + call get_param(param_file, mdl, "ALLOW_GLC_RUNOFF_DIAGNOSTICS", glc_runoff_diags, & + "If true, makes available diagnostics of separate glacier runoff fluxes"//& + "as seen by MOM6.", default=.false.) + call register_forcing_type_diags(Time, diag, US, CS%use_temperature, CS%handles, & - use_berg_fluxes=iceberg_flux_diags, use_waves=use_waves, use_cfcs=CS%use_CFC) + use_berg_fluxes=iceberg_flux_diags, use_waves=use_waves, & + use_cfcs=CS%use_CFC, use_glc_runoff=glc_runoff_diags) call get_param(param_file, mdl, "ALLOW_FLUX_ADJUSTMENTS", CS%allow_flux_adjustments, & "If true, allows flux adjustments to specified via the "//& @@ -1541,6 +1574,8 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) chks = field_chksum( iobt%fprec ) ; if (root) write(outunit,100) 'iobt%fprec ', chks chks = field_chksum( iobt%lrunoff ) ; if (root) write(outunit,100) 'iobt%lrunoff ', chks chks = field_chksum( iobt%frunoff ) ; if (root) write(outunit,100) 'iobt%frunoff ', chks + chks = field_chksum( iobt%lrunoff_glc ) ; if (root) write(outunit,100) 'iobt%lrunoff_glc ', chks + chks = field_chksum( iobt%frunoff_glc ) ; if (root) write(outunit,100) 'iobt%frunoff_glc ', chks chks = field_chksum( iobt%p ) ; if (root) write(outunit,100) 'iobt%p ', chks if (associated(iobt%ice_fraction)) then chks = field_chksum( iobt%ice_fraction ) ; if (root) write(outunit,100) 'iobt%ice_fraction ', chks @@ -1631,6 +1666,12 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) if (associated(iobt%hcond)) then chks = field_chksum( iobt%hcond ) ; if (root) write(outunit,100) 'iobt%hcond ', chks endif + if (associated(iobt%hrofl_glc)) then + chks = field_chksum( iobt%hrofl_glc ) ; if (root) write(outunit,100) 'iobt%hrofl_glc ', chks + endif + if (associated(iobt%hrofl_glc)) then + chks = field_chksum( iobt%hrofl_glc ) ; if (root) write(outunit,100) 'iobt%hrofl_glc ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) 110 FORMAT(" CHECKSUM::",A30," = ",Z20) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index adf9d29ea3..bef29ffe86 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -114,9 +114,10 @@ module MOM_forcing_type ! components of latent heat fluxes used for diagnostic purposes real, pointer, dimension(:,:) :: & - latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) - latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) - latent_frunoff_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) + latent_evap_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from evaporating liquid water (typically < 0) + latent_fprec_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting fprec (typically < 0) + latent_frunoff_diag => NULL(), & !< latent [Q R Z T-1 ~> W m-2] from melting frunoff (calving) (typically < 0) + latent_frunoff_glc_diag => NULL() !< latent [Q R Z T-1 ~> W m-2] from melting glacier frunoff (typically < 0) ! water mass fluxes into the ocean [R Z T-1 ~> kg m-2 s-1]; these fluxes impact the ocean mass real, pointer, dimension(:,:) :: & @@ -126,6 +127,8 @@ module MOM_forcing_type vprec => NULL(), & !< virtual liquid precip associated w/ SSS restoring [R Z T-1 ~> kg m-2 s-1] lrunoff => NULL(), & !< liquid river runoff entering ocean [R Z T-1 ~> kg m-2 s-1] frunoff => NULL(), & !< frozen river runoff (calving) entering ocean [R Z T-1 ~> kg m-2 s-1] + lrunoff_glc => NULL(), & !< liquid river glacier runoff entering ocean [R Z T-1 ~> kg m-2 s-1] + frunoff_glc => NULL(), & !< frozen river glacier runoff entering ocean [R Z T-1 ~> kg m-2 s-1] seaice_melt => NULL() !< snow/seaice melt (positive) or formation (negative) [R Z T-1 ~> kg m-2 s-1] ! Integrated water mass fluxes into the ocean, used for passive tracer sources [H ~> m or kg m-2] @@ -137,15 +140,17 @@ module MOM_forcing_type ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & - heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] - heat_content_evap => NULL(), & !< heat content associated with evaporating water [Q R Z T-1 ~> W m-2] - heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] - heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] - heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] - heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] - heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] - heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] - heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] + heat_content_cond => NULL(), & !< heat content associated with condensating water [Q R Z T-1 ~> W m-2] + heat_content_evap => NULL(), & !< heat content associated with evaporating water [Q R Z T-1 ~> W m-2] + heat_content_lprec => NULL(), & !< heat content associated with liquid >0 precip [Q R Z T-1 ~> W m-2] + heat_content_fprec => NULL(), & !< heat content associated with frozen precip [Q R Z T-1 ~> W m-2] + heat_content_vprec => NULL(), & !< heat content associated with virtual >0 precip [Q R Z T-1 ~> W m-2] + heat_content_lrunoff => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_lrunoff_glc => NULL(), & !< heat content associated with liquid runoff [Q R Z T-1 ~> W m-2] + heat_content_frunoff_glc => NULL(), & !< heat content associated with frozen runoff [Q R Z T-1 ~> W m-2] + heat_content_massout => NULL(), & !< heat content associated with mass leaving ocean [Q R Z T-1 ~> W m-2] + heat_content_massin => NULL() !< heat content associated with mass entering ocean [Q R Z T-1 ~> W m-2] ! salt mass flux (contributes to ocean mass only if non-Bouss ) real, pointer, dimension(:,:) :: & @@ -323,6 +328,7 @@ module MOM_forcing_type integer :: id_precip = -1, id_vprec = -1 integer :: id_lprec = -1, id_fprec = -1 integer :: id_lrunoff = -1, id_frunoff = -1 + integer :: id_lrunoff_glc = -1, id_frunoff_glc = -1 integer :: id_net_massout = -1, id_net_massin = -1 integer :: id_massout_flux = -1, id_massin_flux = -1 integer :: id_seaice_melt = -1 @@ -332,6 +338,7 @@ module MOM_forcing_type integer :: id_total_precip = -1, id_total_vprec = -1 integer :: id_total_lprec = -1, id_total_fprec = -1 integer :: id_total_lrunoff = -1, id_total_frunoff = -1 + integer :: id_total_lrunoff_glc = -1, id_total_frunoff_glc = -1 integer :: id_total_net_massout = -1, id_total_net_massin = -1 integer :: id_total_seaice_melt = -1 @@ -341,34 +348,38 @@ module MOM_forcing_type integer :: id_precip_ga = -1, id_vprec_ga= -1 ! heat flux diagnostic handles - integer :: id_net_heat_coupler = -1, id_net_heat_surface = -1 - integer :: id_sens = -1, id_LwLatSens = -1 - integer :: id_sw = -1, id_lw = -1 - integer :: id_sw_vis = -1, id_sw_nir = -1 - integer :: id_lat_evap = -1, id_lat_frunoff = -1 - integer :: id_lat = -1, id_lat_fprec = -1 - integer :: id_heat_content_lrunoff= -1, id_heat_content_frunoff = -1 - integer :: id_heat_content_lprec = -1, id_heat_content_fprec = -1 - integer :: id_heat_content_cond = -1, id_heat_content_surfwater= -1 - integer :: id_heat_content_evap = -1 - integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 - integer :: id_heat_added = -1, id_heat_content_massin = -1 - integer :: id_hfrainds = -1, id_hfrunoffds = -1 - integer :: id_seaice_melt_heat = -1 + integer :: id_net_heat_coupler = -1, id_net_heat_surface = -1 + integer :: id_sens = -1, id_LwLatSens = -1 + integer :: id_sw = -1, id_lw = -1 + integer :: id_sw_vis = -1, id_sw_nir = -1 + integer :: id_lat_evap = -1, id_lat_frunoff = -1 + integer :: id_lat_frunoff_glc = -1 + integer :: id_lat = -1, id_lat_fprec = -1 + integer :: id_heat_content_lrunoff = -1, id_heat_content_frunoff = -1 + integer :: id_heat_content_lrunoff_glc= -1, id_heat_content_frunoff_glc= -1 + integer :: id_heat_content_lprec = -1, id_heat_content_fprec = -1 + integer :: id_heat_content_cond = -1, id_heat_content_surfwater = -1 + integer :: id_heat_content_evap = -1 + integer :: id_heat_content_vprec = -1, id_heat_content_massout = -1 + integer :: id_heat_added = -1, id_heat_content_massin = -1 + integer :: id_hfrainds = -1, id_hfrunoffds = -1 + integer :: id_seaice_melt_heat = -1 ! global area integrated heat flux diagnostic handles - integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 - integer :: id_total_sens = -1, id_total_LwLatSens = -1 - integer :: id_total_sw = -1, id_total_lw = -1 - integer :: id_total_lat_evap = -1, id_total_lat_frunoff = -1 - integer :: id_total_lat = -1, id_total_lat_fprec = -1 - integer :: id_total_heat_content_lrunoff= -1, id_total_heat_content_frunoff = -1 - integer :: id_total_heat_content_lprec = -1, id_total_heat_content_fprec = -1 - integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater= -1 - integer :: id_total_heat_content_evap = -1 - integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 - integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 - integer :: id_total_seaice_melt_heat = -1 + integer :: id_total_net_heat_coupler = -1, id_total_net_heat_surface = -1 + integer :: id_total_sens = -1, id_total_LwLatSens = -1 + integer :: id_total_sw = -1, id_total_lw = -1 + integer :: id_total_lat_evap = -1, id_total_lat_frunoff = -1 + integer :: id_total_lat_frunoff_glc = -1 + integer :: id_total_lat = -1, id_total_lat_fprec = -1 + integer :: id_total_heat_content_lrunoff = -1, id_total_heat_content_frunoff = -1 + integer :: id_total_heat_content_lrunoff_glc= -1, id_total_heat_content_frunoff_glc=-1 + integer :: id_total_heat_content_lprec = -1, id_total_heat_content_fprec = -1 + integer :: id_total_heat_content_cond = -1, id_total_heat_content_surfwater = -1 + integer :: id_total_heat_content_evap = -1 + integer :: id_total_heat_content_vprec = -1, id_total_heat_content_massout = -1 + integer :: id_total_heat_added = -1, id_total_heat_content_massin = -1 + integer :: id_total_seaice_melt_heat = -1 ! global area averaged heat flux diagnostic handles integer :: id_net_heat_coupler_ga = -1, id_net_heat_surface_ga = -1 @@ -609,23 +620,27 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! net volume/mass of liquid and solid passing through surface boundary fluxes netMassInOut(i) = dt * (scale * & - (((((( fluxes%lprec(i,j) & + (((((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & + + fluxes%lrunoff_glc(i,j)) & + fluxes%vprec(i,j) ) & + fluxes%seaice_melt(i,j)) & - + fluxes%frunoff(i,j) )) + + fluxes%frunoff(i,j) ) & + + fluxes%frunoff_glc(i,j))) if (do_NMIOr) then ! Repeat the above code without multiplying by a timestep for legacy reasons netMassInOut_rate(i) = (scale * & - (((((( fluxes%lprec(i,j) & + (((((((( fluxes%lprec(i,j) & + fluxes%fprec(i,j) ) & + fluxes%evap(i,j) ) & + fluxes%lrunoff(i,j) ) & + + fluxes%lrunoff_glc(i,j)) & + fluxes%vprec(i,j) ) & + fluxes%seaice_melt(i,j)) & - + fluxes%frunoff(i,j) )) + + fluxes%frunoff(i,j) ) & + + fluxes%frunoff_glc(i,j))) endif ! smg: @@ -700,6 +715,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! remove lrunoff*SST here, to counteract its addition elsewhere net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff(i,j)) - & (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff(i,j) * T(i,1) + net_heat(i) = (net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_lrunoff_glc(i,j)) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%lrunoff_glc(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. !if (do_NHR) net_heat_rate(i) = (net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_lrunoff(i,j)) - & @@ -708,6 +725,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_lrunoff(i,j) - fluxes%lrunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_lrunoff_glc(i,j) - fluxes%lrunoff_glc(i,j)*T(i,1)) endif endif @@ -717,6 +736,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & ! remove frunoff*SST here, to counteract its addition elsewhere net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff(i,j) - & (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff(i,j) * T(i,1) + net_heat(i) = net_heat(i) + (scale*(dt * I_Cp_Hconvert)) * fluxes%heat_content_frunoff_glc(i,j) - & + (GV%RZ_to_H * (scale * dt)) * fluxes%frunoff_glc(i,j) * T(i,1) !BGR-Jul 5, 2017{ !Intentionally neglect the following contribution to rate for legacy reasons. ! if (do_NHR) net_heat_rate(i) = net_heat_rate(i) + (scale*I_Cp_Hconvert) * fluxes%heat_content_frunoff(i,j) - & @@ -725,6 +746,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (calculate_diags .and. associated(tv%TempxPmE)) then tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & (I_Cp*fluxes%heat_content_frunoff(i,j) - fluxes%frunoff(i,j)*T(i,1)) + tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + (scale * dt) * & + (I_Cp*fluxes%heat_content_frunoff_glc(i,j) - fluxes%frunoff_glc(i,j)*T(i,1)) endif endif @@ -748,6 +771,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (.not. do_enthalpy) then net_heat(i) = net_heat(i) + (scale * dt * I_Cp_Hconvert * & (fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(i,j) + & + fluxes%heat_content_lrunoff_glc(i,j) + fluxes%heat_content_frunoff_glc(i,j) + & fluxes%heat_content_lprec(i,j) + fluxes%heat_content_fprec(i,j) + & fluxes%heat_content_evap(i,j) + fluxes%heat_content_cond(i,j))) endif @@ -876,6 +900,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (associated(fluxes%lrunoff) .and. associated(fluxes%heat_content_lrunoff)) then fluxes%heat_content_lrunoff(i,j) = tv%C_p*fluxes%lrunoff(i,j)*T(i,1) endif + if (associated(fluxes%lrunoff_glc) .and. associated(fluxes%heat_content_lrunoff_glc)) then + fluxes%heat_content_lrunoff_glc(i,j) = tv%C_p*fluxes%lrunoff_glc(i,j)*T(i,1) + endif endif ! Icebergs enter ocean at SST if land model does not provide calving heat content. @@ -883,6 +910,9 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & if (associated(fluxes%frunoff) .and. associated(fluxes%heat_content_frunoff)) then fluxes%heat_content_frunoff(i,j) = tv%C_p*fluxes%frunoff(i,j)*T(i,1) endif + if (associated(fluxes%frunoff_glc) .and. associated(fluxes%heat_content_frunoff_glc)) then + fluxes%heat_content_frunoff_glc(i,j) = tv%C_p*fluxes%frunoff_glc(i,j)*T(i,1) + endif endif elseif (.not. do_enthalpy) then @@ -905,6 +935,8 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & fluxes%heat_content_fprec(i,j) + & fluxes%heat_content_lrunoff(i,j) + & fluxes%heat_content_frunoff(i,j) + & + fluxes%heat_content_lrunoff_glc(i,j) + & + fluxes%heat_content_frunoff_glc(i,j) + & fluxes%heat_content_evap(i,j) + & fluxes%heat_content_cond(i,j)) endif @@ -1309,6 +1341,9 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) if (associated(fluxes%latent_frunoff_diag)) & call hchksum(fluxes%latent_frunoff_diag, mesg//" fluxes%latent_frunoff_diag", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%latent_frunoff_glc_diag)) & + call hchksum(fluxes%latent_frunoff_glc_diag, mesg//" fluxes%latent_frunoff_glc_diag", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sens)) & call hchksum(fluxes%sens, mesg//" fluxes%sens", G%HI, haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%evap)) & @@ -1338,14 +1373,24 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%ustar_tidal, mesg//" fluxes%ustar_tidal", G%HI, haloshift=hshift, scale=US%Z_to_m*US%s_to_T) if (associated(fluxes%lrunoff)) & call hchksum(fluxes%lrunoff, mesg//" fluxes%lrunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%lrunoff_glc)) & + call hchksum(fluxes%lrunoff_glc, mesg//" fluxes%lrunoff_glc", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%frunoff)) & call hchksum(fluxes%frunoff, mesg//" fluxes%frunoff", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) + if (associated(fluxes%frunoff_glc)) & + call hchksum(fluxes%frunoff_glc, mesg//" fluxes%frunoff_glc", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%heat_content_lrunoff)) & call hchksum(fluxes%heat_content_lrunoff, mesg//" fluxes%heat_content_lrunoff", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_lrunoff_glc)) & + call hchksum(fluxes%heat_content_lrunoff_glc, mesg//" fluxes%heat_content_lrunoff_glc", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_frunoff)) & call hchksum(fluxes%heat_content_frunoff, mesg//" fluxes%heat_content_frunoff", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) + if (associated(fluxes%heat_content_frunoff_glc)) & + call hchksum(fluxes%heat_content_frunoff_glc, mesg//" fluxes%heat_content_frunoff_glc", G%HI, & + haloshift=hshift, scale=US%QRZ_T_to_W_m2) if (associated(fluxes%heat_content_lprec)) & call hchksum(fluxes%heat_content_lprec, mesg//" fluxes%heat_content_lprec", G%HI, & haloshift=hshift, scale=US%QRZ_T_to_W_m2) @@ -1448,6 +1493,7 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%latent_evap_diag,'latent_evap_diag') call locMsg(fluxes%latent_fprec_diag,'latent_fprec_diag') call locMsg(fluxes%latent_frunoff_diag,'latent_frunoff_diag') + call locMsg(fluxes%latent_frunoff_glc_diag,'latent_frunoff_glc_diag') call locMsg(fluxes%sens,'sens') call locMsg(fluxes%evap,'evap') call locMsg(fluxes%lprec,'lprec') @@ -1460,9 +1506,13 @@ subroutine forcing_SinglePointPrint(fluxes, G, i, j, mesg) call locMsg(fluxes%TKE_tidal,'TKE_tidal') call locMsg(fluxes%ustar_tidal,'ustar_tidal') call locMsg(fluxes%lrunoff,'lrunoff') + call locMsg(fluxes%lrunoff_glc,'lrunoff_glc') call locMsg(fluxes%frunoff,'frunoff') + call locMsg(fluxes%frunoff_glc,'frunoff_glc') call locMsg(fluxes%heat_content_lrunoff,'heat_content_lrunoff') + call locMsg(fluxes%heat_content_lrunoff_glc,'heat_content_lrunoff_glc') call locMsg(fluxes%heat_content_frunoff,'heat_content_frunoff') + call locMsg(fluxes%heat_content_frunoff_glc,'heat_content_frunoff_glc') call locMsg(fluxes%heat_content_lprec,'heat_content_lprec') call locMsg(fluxes%heat_content_fprec,'heat_content_fprec') call locMsg(fluxes%heat_content_vprec,'heat_content_vprec') @@ -1489,7 +1539,8 @@ end subroutine forcing_SinglePointPrint !> Register members of the forcing type for diagnostics -subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, use_cfcs) +subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, use_berg_fluxes, use_waves, & + use_cfcs, use_glc_runoff) type(time_type), intent(in) :: Time !< time type type(diag_ctrl), intent(inout) :: diag !< diagnostic control type type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1498,6 +1549,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, logical, optional, intent(in) :: use_berg_fluxes !< If true, allow iceberg flux diagnostics logical, optional, intent(in) :: use_waves !< If true, allow wave forcing diagnostics logical, optional, intent(in) :: use_cfcs !< If true, allow cfc related diagnostics + logical, optional, intent(in) :: use_glc_runoff !< If true, allow separate glacial runoff diagnostics ! Clock for forcing diagnostics handles%id_clock_forcing=cpu_clock_id('(Ocean forcing diagnostics)', grain=CLOCK_ROUTINE) @@ -1634,6 +1686,18 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='water_flux_into_sea_water_from_rivers', & cmor_long_name='Water Flux into Sea Water From Rivers') + if (present(use_glc_runoff)) then + handles%id_frunoff_glc = register_diag_field('ocean_model', 'frunoff_glc', diag%axesT1, Time, & + 'Frozen glacier runoff (calving) and iceberg melt into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='glc_water_flux_into_sea_water_from_icebergs') ! todo: update cmor names + + handles%id_lrunoff_glc = register_diag_field('ocean_model', 'lrunoff_glc', diag%axesT1, Time, & + 'Liquid runoff (glaciers) into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_from_glaciers') ! todo: update cmor names + endif + handles%id_net_massout = register_diag_field('ocean_model', 'net_massout', diag%axesT1, Time, & 'Net mass leaving the ocean due to evaporation, seaice formation', & 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) @@ -1707,6 +1771,14 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='water_flux_into_sea_water_from_rivers_area_integrated', & cmor_long_name='Water Flux into Sea Water From Rivers Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_frunoff_glc = register_scalar_field('ocean_model', 'total_frunoff_glc', Time, diag, & + long_name='Area integrated frozen glacier runoff (calving) & iceberg melt into ocean', units='kg s-1') + + handles%id_total_lrunoff_glc = register_scalar_field('ocean_model', 'total_lrunoff_glc', Time, diag,& + long_name='Area integrated liquid glacier runoff into ocean', units='kg s-1') + endif + handles%id_total_net_massout = register_scalar_field('ocean_model', 'total_net_massout', Time, diag, & long_name='Area integrated mass leaving ocean due to evap and seaice form', units='kg s-1') @@ -1765,6 +1837,16 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='temperature_flux_due_to_runoff_expressed_as_heat_flux_into_sea_water') + if (present(use_glc_runoff)) then + handles%id_heat_content_frunoff_glc = register_diag_field('ocean_model', 'heat_content_frunoff_glc', & + diag%axesT1, Time, 'Heat content (relative to 0C) of solid glacier runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + + handles%id_heat_content_lrunoff_glc = register_diag_field('ocean_model', 'heat_content_lrunoff_glc', & + diag%axesT1, Time, 'Heat content (relative to 0C) of liquid glacier runoff into ocean', & + 'W m-2', conversion=US%QRZ_T_to_W_m2) + endif + handles%id_hfrunoffds = register_diag_field('ocean_model', 'hfrunoffds', & diag%axesT1, Time, 'Heat content (relative to 0C) of liquid+solid runoff into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2, & @@ -1868,6 +1950,11 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_standard_name='heat_flux_into_sea_water_due_to_iceberg_thermodynamics', & cmor_long_name='Latent Heat to Melt Frozen Runoff/Iceberg') + if (present(use_glc_runoff)) then + handles%id_lat_frunoff_glc = register_diag_field('ocean_model', 'latent_frunoff_glc', diag%axesT1, Time, & + 'Latent heat flux into ocean due to melting of frozen glacier runoff', 'W m-2', conversion=US%QRZ_T_to_W_m2) + endif + handles%id_sens = register_diag_field('ocean_model', 'sensible', diag%axesT1, Time, & 'Sensible heat flux into ocean', 'W m-2', conversion=US%QRZ_T_to_W_m2, & standard_name='surface_downward_sensible_heat_flux', & @@ -1907,6 +1994,18 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name= & 'Temperature Flux due to Runoff Expressed as Heat Flux into Sea Water Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_heat_content_frunoff_glc = register_scalar_field('ocean_model', & + 'total_heat_content_frunoff_glc', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of solid glacier runoff', & + units='W') ! todo: update cmor names + + handles%id_total_heat_content_lrunoff_glc = register_scalar_field('ocean_model', & + 'total_heat_content_lrunoff_glc', Time, diag, & + long_name='Area integrated heat content (relative to 0C) of liquid glacier runoff', & + units='W') ! todo: update cmor names + endif + handles%id_total_heat_content_lprec = register_scalar_field('ocean_model', & 'total_heat_content_lprec', Time, diag, & long_name='Area integrated heat content (relative to 0C) of liquid precip', & @@ -2024,6 +2123,13 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, cmor_long_name= & 'Heat Flux into Sea Water due to Iceberg Thermodynamics Area Integrated') + if (present(use_glc_runoff)) then + handles%id_total_lat_frunoff_glc = register_scalar_field('ocean_model', & + 'total_lat_frunoff_glc', Time, diag, & + long_name='Area integrated latent heat flux due to melting frozen glacier runoff', & + units='W') ! todo: update cmor names + endif + handles%id_total_sens = register_scalar_field('ocean_model', & 'total_sens', Time, diag, & long_name='Area integrated downward sensible heat flux', & @@ -2287,6 +2393,8 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%vprec(i,j) = wt1*fluxes%vprec(i,j) + wt2*flux_tmp%vprec(i,j) fluxes%lrunoff(i,j) = wt1*fluxes%lrunoff(i,j) + wt2*flux_tmp%lrunoff(i,j) fluxes%frunoff(i,j) = wt1*fluxes%frunoff(i,j) + wt2*flux_tmp%frunoff(i,j) + fluxes%lrunoff_glc(i,j) = wt1*fluxes%lrunoff_glc(i,j) + wt2*flux_tmp%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j) = wt1*fluxes%frunoff_glc(i,j) + wt2*flux_tmp%frunoff_glc(i,j) fluxes%seaice_melt(i,j) = wt1*fluxes%seaice_melt(i,j) + wt2*flux_tmp%seaice_melt(i,j) fluxes%sw(i,j) = wt1*fluxes%sw(i,j) + wt2*flux_tmp%sw(i,j) fluxes%sw_vis_dir(i,j) = wt1*fluxes%sw_vis_dir(i,j) + wt2*flux_tmp%sw_vis_dir(i,j) @@ -2340,6 +2448,18 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%heat_content_frunoff(i,j) = wt1*fluxes%heat_content_frunoff(i,j) + wt2*flux_tmp%heat_content_frunoff(i,j) enddo ; enddo endif + if (associated(fluxes%heat_content_lrunoff_glc) .and. associated(flux_tmp%heat_content_lrunoff_glc)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_lrunoff_glc(i,j) = wt1*fluxes%heat_content_lrunoff_glc(i,j) + & + wt2*flux_tmp%heat_content_lrunoff_glc(i,j) + enddo ; enddo + endif + if (associated(fluxes%heat_content_frunoff_glc) .and. associated(flux_tmp%heat_content_frunoff_glc)) then + do j=js,je ; do i=is,ie + fluxes%heat_content_frunoff_glc(i,j) = wt1*fluxes%heat_content_frunoff_glc(i,j) + & + wt2*flux_tmp%heat_content_frunoff_glc(i,j) + enddo ; enddo + endif if (associated(fluxes%ustar_shelf) .and. associated(flux_tmp%ustar_shelf)) then do i=isd,ied ; do j=jsd,jed @@ -2511,6 +2631,12 @@ subroutine get_net_mass_forcing(fluxes, G, US, net_mass_src) if (associated(fluxes%frunoff)) then ; do j=js,je ; do i=is,ie net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff(i,j) enddo ; enddo ; endif + if (associated(fluxes%lrunoff_glc)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%lrunoff_glc(i,j) + enddo ; enddo ; endif + if (associated(fluxes%frunoff_glc)) then ; do j=js,je ; do i=is,ie + net_mass_src(i,j) = net_mass_src(i,j) + fluxes%frunoff_glc(i,j) + enddo ; enddo ; endif if (associated(fluxes%evap)) then ; do j=js,je ; do i=is,ie net_mass_src(i,j) = net_mass_src(i,j) + fluxes%evap(i,j) enddo ; enddo ; endif @@ -2671,6 +2797,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%evap)) res(i,j) = res(i,j) + fluxes%evap(i,j) if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + if (associated(fluxes%lrunoff_glc)) res(i,j) = res(i,j) + fluxes%lrunoff_glc(i,j) + if (associated(fluxes%frunoff_glc)) res(i,j) = res(i,j) + fluxes%frunoff_glc(i,j) if (associated(fluxes%vprec)) res(i,j) = res(i,j) + fluxes%vprec(i,j) if (associated(fluxes%seaice_melt)) res(i,j) = res(i,j) + fluxes%seaice_melt(i,j) enddo ; enddo @@ -2718,6 +2846,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (associated(fluxes%fprec)) res(i,j) = res(i,j) + fluxes%fprec(i,j) if (associated(fluxes%lrunoff)) res(i,j) = res(i,j) + fluxes%lrunoff(i,j) if (associated(fluxes%frunoff)) res(i,j) = res(i,j) + fluxes%frunoff(i,j) + if (associated(fluxes%lrunoff_glc)) res(i,j) = res(i,j) + fluxes%lrunoff_glc(i,j) + if (associated(fluxes%frunoff_glc)) res(i,j) = res(i,j) + fluxes%frunoff_glc(i,j) if (associated(fluxes%lprec)) then if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) @@ -2813,6 +2943,14 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif endif + if (associated(fluxes%lrunoff_glc)) then + if (handles%id_lrunoff_glc > 0) call post_data(handles%id_lrunoff_glc, fluxes%lrunoff_glc, diag) + if (handles%id_total_lrunoff_glc > 0) then + total_transport = global_area_integral(fluxes%lrunoff_glc, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_lrunoff_glc, total_transport, diag) + endif + endif + if (associated(fluxes%frunoff)) then if (handles%id_frunoff > 0) call post_data(handles%id_frunoff, fluxes%frunoff, diag) if (handles%id_total_frunoff > 0) then @@ -2821,6 +2959,14 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h endif endif + if (associated(fluxes%frunoff_glc)) then + if (handles%id_frunoff_glc > 0) call post_data(handles%id_frunoff_glc, fluxes%frunoff_glc, diag) + if (handles%id_total_frunoff_glc > 0) then + total_transport = global_area_integral(fluxes%frunoff_glc, G, scale=US%RZ_T_to_kg_m2s) + call post_data(handles%id_total_frunoff_glc, total_transport, diag) + endif + endif + if (associated(fluxes%seaice_melt)) then if (handles%id_seaice_melt > 0) call post_data(handles%id_seaice_melt, fluxes%seaice_melt, diag) if (handles%id_total_seaice_melt > 0) then @@ -2838,12 +2984,26 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_heat_content_lrunoff, total_transport, diag) endif + + if ((handles%id_heat_content_lrunoff_glc > 0) .and. associated(fluxes%heat_content_lrunoff_glc)) & + call post_data(handles%id_heat_content_lrunoff_glc, fluxes%heat_content_lrunoff_glc, diag) + if ((handles%id_total_heat_content_lrunoff_glc > 0) .and. associated(fluxes%heat_content_lrunoff_glc)) then + total_transport = global_area_integral(fluxes%heat_content_lrunoff_glc, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_lrunoff_glc, total_transport, diag) + endif + if ((handles%id_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) & call post_data(handles%id_heat_content_frunoff, fluxes%heat_content_frunoff, diag) if ((handles%id_total_heat_content_frunoff > 0) .and. associated(fluxes%heat_content_frunoff)) then total_transport = global_area_integral(fluxes%heat_content_frunoff, G, scale=US%QRZ_T_to_W_m2) call post_data(handles%id_total_heat_content_frunoff, total_transport, diag) endif + if ((handles%id_heat_content_frunoff_glc > 0) .and. associated(fluxes%heat_content_frunoff_glc)) & + call post_data(handles%id_heat_content_frunoff_glc, fluxes%heat_content_frunoff_glc, diag) + if ((handles%id_total_heat_content_frunoff_glc > 0) .and. associated(fluxes%heat_content_frunoff_glc)) then + total_transport = global_area_integral(fluxes%heat_content_frunoff_glc, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_heat_content_frunoff_glc, total_transport, diag) + endif if ((handles%id_heat_content_lprec > 0) .and. associated(fluxes%heat_content_lprec)) & call post_data(handles%id_heat_content_lprec, fluxes%heat_content_lprec, diag) @@ -2929,6 +3089,10 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) if (associated(fluxes%heat_content_frunoff)) & res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) & + res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) & + res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) if (associated(fluxes%heat_content_lprec)) & res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) if (associated(fluxes%heat_content_fprec)) & @@ -2961,12 +3125,14 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_heat_content_surfwater > 0 .or. handles%id_total_heat_content_surfwater > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) - if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) - if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_vprec)) res(i,j) = res(i,j) + fluxes%heat_content_vprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) if (mom_enthalpy) then if (associated(fluxes%heat_content_massout)) res(i,j) = res(i,j) + fluxes%heat_content_massout(i,j) else @@ -2986,6 +3152,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h res(i,j) = 0.0 if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff_glc(i,j) + if (associated(fluxes%heat_content_frunoff_glc)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff_glc(i,j) enddo ; enddo call post_data(handles%id_hfrunoffds, res, diag) endif @@ -3095,6 +3263,14 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif + if ((handles%id_lat_frunoff_glc > 0) .and. associated(fluxes%latent_frunoff_glc_diag)) then + call post_data(handles%id_lat_frunoff_glc, fluxes%latent_frunoff_glc_diag, diag) + endif + if (handles%id_total_lat_frunoff_glc > 0 .and. associated(fluxes%latent_frunoff_glc_diag)) then + total_transport = global_area_integral(fluxes%latent_frunoff_glc_diag, G, scale=US%QRZ_T_to_W_m2) + call post_data(handles%id_total_lat_frunoff_glc, total_transport, diag) + endif + if ((handles%id_sens > 0) .and. associated(fluxes%sens)) then call post_data(handles%id_sens, fluxes%sens, diag) endif @@ -3278,6 +3454,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%vprec,isd,ied,jsd,jed, water) call myAlloc(fluxes%lrunoff,isd,ied,jsd,jed, water) call myAlloc(fluxes%frunoff,isd,ied,jsd,jed, water) + call myAlloc(fluxes%lrunoff_glc,isd,ied,jsd,jed, water) + call myAlloc(fluxes%frunoff_glc,isd,ied,jsd,jed, water) call myAlloc(fluxes%seaice_melt,isd,ied,jsd,jed, water) call myAlloc(fluxes%netMassOut,isd,ied,jsd,jed, water) call myAlloc(fluxes%netMassIn,isd,ied,jsd,jed, water) @@ -3289,6 +3467,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%latent_evap_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent_fprec_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%latent_frunoff_diag,isd,ied,jsd,jed, heat) + call myAlloc(fluxes%latent_frunoff_glc_diag,isd,ied,jsd,jed, heat) call myAlloc(fluxes%salt_flux,isd,ied,jsd,jed, salt) @@ -3300,6 +3479,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%heat_content_vprec,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_lrunoff,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_frunoff,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_lrunoff_glc,isd,ied,jsd,jed, .true.) + call myAlloc(fluxes%heat_content_frunoff_glc,isd,ied,jsd,jed, .true.) call myAlloc(fluxes%heat_content_massout,isd,ied,jsd,jed, enthalpy_mom) call myAlloc(fluxes%heat_content_massin,isd,ied,jsd,jed, enthalpy_mom) endif ; endif @@ -3583,10 +3764,13 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%latent_evap_diag)) deallocate(fluxes%latent_evap_diag) if (associated(fluxes%latent_fprec_diag)) deallocate(fluxes%latent_fprec_diag) if (associated(fluxes%latent_frunoff_diag)) deallocate(fluxes%latent_frunoff_diag) + if (associated(fluxes%latent_frunoff_glc_diag)) deallocate(fluxes%latent_frunoff_glc_diag) if (associated(fluxes%sens)) deallocate(fluxes%sens) if (associated(fluxes%heat_added)) deallocate(fluxes%heat_added) if (associated(fluxes%heat_content_lrunoff)) deallocate(fluxes%heat_content_lrunoff) if (associated(fluxes%heat_content_frunoff)) deallocate(fluxes%heat_content_frunoff) + if (associated(fluxes%heat_content_lrunoff_glc)) deallocate(fluxes%heat_content_lrunoff_glc) + if (associated(fluxes%heat_content_frunoff_glc)) deallocate(fluxes%heat_content_frunoff_glc) if (associated(fluxes%heat_content_lprec)) deallocate(fluxes%heat_content_lprec) if (associated(fluxes%heat_content_fprec)) deallocate(fluxes%heat_content_fprec) if (associated(fluxes%heat_content_cond)) deallocate(fluxes%heat_content_cond) @@ -3599,6 +3783,8 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%vprec)) deallocate(fluxes%vprec) if (associated(fluxes%lrunoff)) deallocate(fluxes%lrunoff) if (associated(fluxes%frunoff)) deallocate(fluxes%frunoff) + if (associated(fluxes%lrunoff_glc)) deallocate(fluxes%lrunoff_glc) + if (associated(fluxes%frunoff_glc)) deallocate(fluxes%frunoff_glc) if (associated(fluxes%seaice_melt)) deallocate(fluxes%seaice_melt) if (associated(fluxes%netMassOut)) deallocate(fluxes%netMassOut) if (associated(fluxes%netMassIn)) deallocate(fluxes%netMassIn) @@ -3682,6 +3868,8 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%vprec, turns, fluxes%vprec) call rotate_array(fluxes_in%lrunoff, turns, fluxes%lrunoff) call rotate_array(fluxes_in%frunoff, turns, fluxes%frunoff) + call rotate_array(fluxes_in%lrunoff_glc, turns, fluxes%lrunoff_glc) + call rotate_array(fluxes_in%frunoff_glc, turns, fluxes%frunoff_glc) call rotate_array(fluxes_in%seaice_melt, turns, fluxes%seaice_melt) call rotate_array(fluxes_in%netMassOut, turns, fluxes%netMassOut) call rotate_array(fluxes_in%netMassIn, turns, fluxes%netMassIn) @@ -3696,6 +3884,7 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%latent_evap_diag, turns, fluxes%latent_evap_diag) call rotate_array(fluxes_in%latent_fprec_diag, turns, fluxes%latent_fprec_diag) call rotate_array(fluxes_in%latent_frunoff_diag, turns, fluxes%latent_frunoff_diag) + call rotate_array(fluxes_in%latent_frunoff_glc_diag, turns, fluxes%latent_frunoff_glc_diag) endif if (do_salt) then @@ -3708,7 +3897,9 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%heat_content_fprec, turns, fluxes%heat_content_fprec) call rotate_array(fluxes_in%heat_content_vprec, turns, fluxes%heat_content_vprec) call rotate_array(fluxes_in%heat_content_lrunoff, turns, fluxes%heat_content_lrunoff) + call rotate_array(fluxes_in%heat_content_lrunoff_glc, turns, fluxes%heat_content_lrunoff_glc) call rotate_array(fluxes_in%heat_content_frunoff, turns, fluxes%heat_content_frunoff) + call rotate_array(fluxes_in%heat_content_frunoff_glc, turns, fluxes%heat_content_frunoff_glc) if (associated (fluxes_in%heat_content_evap)) then call rotate_array(fluxes_in%heat_content_evap, turns, fluxes%heat_content_evap) else @@ -3956,6 +4147,8 @@ subroutine homogenize_forcing(fluxes, G, GV, US) call homogenize_field_t(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call homogenize_field_t(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) call homogenize_field_t(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff_glc, G, tmp_scale=US%RZ_T_to_kg_m2s) call homogenize_field_t(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) ! These two calls might not be needed. call homogenize_field_t(fluxes%netMassOut, G, tmp_scale=GV%H_to_mks) @@ -3974,6 +4167,7 @@ subroutine homogenize_forcing(fluxes, G, GV, US) call homogenize_field_t(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_glc_diag, G, tmp_scale=US%QRZ_T_to_W_m2) endif if (do_salt) call homogenize_field_t(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) @@ -3985,6 +4179,8 @@ subroutine homogenize_forcing(fluxes, G, GV, US) call homogenize_field_t(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff_glc, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) call homogenize_field_t(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index fb95b79a91..fdcee8107d 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -966,8 +966,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) if (associated(fluxes%lprec) .and. associated(fluxes%fprec)) then do j=js,je ; do i=is,ie FW_in(i,j) = RZL2_to_kg * dt*G%areaT(i,j)*(fluxes%evap(i,j) + & - (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j)) + & - (fluxes%fprec(i,j) + fluxes%frunoff(i,j)))) + (((fluxes%lprec(i,j) + fluxes%vprec(i,j)) + fluxes%lrunoff(i,j) + fluxes%lrunoff_glc(i,j)) + & + (fluxes%fprec(i,j) + fluxes%frunoff(i,j) + fluxes%frunoff_glc(i,j)))) enddo ; enddo else call MOM_error(WARNING, & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 561ace60a7..e3560dc03e 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -528,13 +528,15 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth do i=is,ie TKE_river(i) = max(0.0, RmixConst * dSpV0_dS(i) * & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) + & + fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j)) * S(i,1)) enddo else RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 do i=is,ie TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) + & + fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j)) * S(i,1)) enddo endif else diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index aa31024b24..c54240aae2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1431,7 +1431,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif cTKE(i,j,k) = cTKE(i,j,k) + max(0.0, RivermixConst*dSV_dS(i,j,1) * & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * tv%S(i,j,1)) + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) + & + fluxes%lrunoff_glc(i,j) + fluxes%frunoff_glc(i,j)) * tv%S(i,j,1)) endif ! Update state From f8f76f2940dd52fcd80d006d68693d26e1e35286 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Fri, 30 Aug 2024 15:35:47 -0600 Subject: [PATCH 22/31] remove doxygen formatting on local variables correct some indentation issues --- src/tracer/MARBL_tracers.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index 93c6988130..0896917f2c 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -1257,12 +1257,12 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [m] -! Local variables + ! Local variables character(len=256) :: log_message - real, dimension(SZI_(G),SZJ_(G)) :: net_salt_rate !< Surface salt flux into the ocean - !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. - real, dimension(SZI_(G),SZJ_(G)) :: flux_from_salt_flux !< Surface tracer flux from salt flux - !! [conc Z T-1 ~> conc m s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: net_salt_rate ! Surface salt flux into the ocean + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: flux_from_salt_flux ! Surface tracer flux from salt flux + ! [conc Z T-1 ~> conc m s-1]. real, dimension(SZI_(G),SZJ_(G)) :: ref_mask ! Mask for 2D MARBL diags using ref_depth real, dimension(SZI_(G),SZJ_(G)) :: riv_flux_loc ! Local copy of CS%RIV_FLUXES*dt real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified @@ -2010,7 +2010,7 @@ function MARBL_tracers_stock(h, stocks, G, GV, CS, names, units, stock_index) integer :: MARBL_tracers_stock !< Return value: the number of stocks !! calculated here. -! Local variables + ! Local variables integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke From a077a61f9b1f3fd081713b560af72459fa6ca729 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 6 Sep 2024 15:37:26 -0600 Subject: [PATCH 23/31] Use longString in MAX_LAYER_THICKNESS (#299) Updated MAX_LAYER_THICKNESS to use longString for handling extended path+filename. --- src/ALE/MOM_regridding.F90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8faec6c495..58bb35d5a7 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -200,7 +200,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=80) :: string, string2, varName ! Temporary strings character(len=40) :: coord_units, coord_res_param ! Temporary strings character(len=MAX_PARAM_LENGTH) :: param_name - character(len=200) :: inputdir, fileName + character(len=200) :: inputdir, fileName, longString character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings logical :: tmpLogical, do_sum, main_parameters @@ -680,7 +680,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Optionally specify maximum thicknesses for each layer, enforced by moving ! the interface below a layer downward. - call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", string, & + call get_param(param_file, mdl, "MAX_LAYER_THICKNESS_CONFIG", longString, & "Determines how to specify the maximum layer thicknesses.\n"//& "Valid options are:\n"//& " NONE - there are no maximum layer thicknesses\n"//& @@ -692,26 +692,26 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default='NONE') message = "The list of maximum thickness for each layer." allocate(h_max(ke)) - if ( trim(string) == "NONE") then + if ( trim(longString) == "NONE") then ! Do nothing. - elseif ( trim(string) == "PARAM") then + elseif ( trim(longString) == "PARAM") then call get_param(param_file, mdl, "MAX_LAYER_THICKNESS", h_max, & trim(message), units="m", fail_if_missing=.true., scale=GV%m_to_H) call set_regrid_max_thickness(CS, h_max) - elseif (index(trim(string),'FILE:')==1) then - if (string(6:6)=='.' .or. string(6:6)=='/') then + elseif (index(trim(longString),'FILE:')==1) then + if (longString(6:6)=='.' .or. longString(6:6)=='/') then ! If we specified "FILE:./xyz" or "FILE:/xyz" then we have a relative or absolute path - fileName = trim( extractWord(trim(string(6:80)), 1) ) + fileName = trim( extractWord(trim(longString(6:200)), 1) ) else ! Otherwise assume we should look for the file in INPUTDIR - fileName = trim(inputdir) // trim( extractWord(trim(string(6:80)), 1) ) + fileName = trim(inputdir) // trim( extractWord(trim(longString(6:200)), 1) ) endif if (.not. file_exists(fileName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(string)//")") + "Specified file not found: Looking for '"//trim(fileName)//"' ("//trim(longString)//")") - varName = trim( extractWord(trim(string(6:)), 2) ) + varName = trim( extractWord(trim(longString(6:)), 2) ) if (.not. field_exists(fileName,varName)) call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(string)//")") + "Specified field not found: Looking for '"//trim(varName)//"' ("//trim(longString)//")") if (len_trim(varName)==0) then if (field_exists(fileName,'h_max')) then; varName = 'h_max' elseif (field_exists(fileName,'dz_max')) then; varName = 'dz_max' @@ -723,14 +723,14 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) - elseif (index(trim(string),'FNC1:')==1) then - call dz_function1( trim(string(6:)), h_max ) + elseif (index(trim(longString),'FNC1:')==1) then + call dz_function1( trim(longString(6:)), h_max ) call log_param(param_file, mdl, "!MAX_LAYER_THICKNESS", h_max, & trim(message), units=coordinateUnits(coord_mode)) call set_regrid_max_thickness(CS, h_max, GV%m_to_H) else call MOM_error(FATAL,trim(mdl)//", initialize_regridding: "// & - "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(string)) + "Unrecognized MAX_LAYER_THICKNESS_CONFIG "//trim(longString)) endif deallocate(h_max) endif From 15deea43ecb97a3920b3a06162363f1bac2b8ba5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Sun, 8 Sep 2024 23:21:05 -0600 Subject: [PATCH 24/31] *Updates in FPMix and Stokes Most (#283) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This PR revises the formulation of the legacy K-profile parameterization (KPP) ocean boundary layer scheme. It incorporates: 1. a non-local momentum flux—the Flux-profile parameterization (`FPMIX`); when the local shear is not aligned with the wind, this scheme adds a non-local momentum flux in the direction of the wind; and 2. mixing with and without waves following the Monin-Obukhov Similarity Theory expanded to include Stokes drift (`STOKES_MOST`). This option provides the transition from waveless to ocean surface waves in any stage of growth or decay. **Summary:** * Uncomment omega w2x entries; * Simplify the nonlocal increments in `vertFPMix`; * In the call to `CVmix_kpp_compute_unresolved_shear`, passes the 2D surface buoyancy flux (`surfBuoyFlux2`) instead of the 1D version (`surfBuoyFlux`), which is preferable. **This is answer changing**; * Remove `uold` and `vold` diagnostics. These were used in an alternative time-stepping scheme that is now obsolete; * Pass boundary layer depths to the RK2 and add consistency check to make sure `FPMix` is always used with `SPLIT`; * Add the capability to mix down the Eulerian gradient instead of the Lagrangian; * Make a minimum set of `FPMix` diagnostics available. This PR relies on https://github.com/CVMix/CVMix-src/pull/94/. New diagnostics: ``` "StokesXI" ! modules: {ocean_model,ocean_model_d2} ! long_name: Stokes Similarity Parameter ! units: nondim ! cell_methods: xh:mean yh:mean area:mean "Lam2" ! modules: {ocean_model,ocean_model_d2} ! long_name: Ustk0_ustar ! units: nondim ! cell_methods: xh:mean yh:mean area:mean "uE_h" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: x-zonal Eulerian ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {uE_h,uE_h_xyave} "vE_h" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: y-merid Eulerian ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {vE_h,vE_h_xyave} "uInc_h" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: x-zonal Eulerian ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {uInc_h,uInc_h_xyave} "vInc_h" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: x-zonal Eulerian ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {vInc_h,vInc_h_xyave} "uStk" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: x-FP du increment ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {uStk,uStk_xyave} "vStk" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: y-FP dv increment ! units: m s-1 ! cell_methods: xh:mean yh:mean zl:mean area:mean ! variants: {vStk,vStk_xyave} "Omega_tau2s" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: Stress direction from shear ! units: radians ! cell_methods: xh:mean yh:mean zi:point area:mean ! variants: {Omega_tau2s,Omega_tau2s_xyave} "Omega_tau2w" ! modules: {ocean_model,ocean_model_z,ocean_model_rho2,ocean_model_d2,ocean_model_z_d2,ocean_model_rho2_d2} ! long_name: Stress direction from wind ! units: radians ! cell_methods: xh:mean yh:mean zi:point area:mean ! variants: {Omega_tau2w,Omega_tau2w_xyave} "uStk0" ! modules: {ocean_model,ocean_model_d2} ! long_name: Zonal Surface Stokes ! units: m s-1 ! cell_methods: xh:mean yh:mean area:mean "vStk0" ! modules: {ocean_model,ocean_model_d2} ! long_name: Merid Surface Stokes ! units: m s-1 ! cell_methods: xh:mean yh:mean area:mean ``` --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 6 +- pkg/CVMix-src | 2 +- src/core/MOM.F90 | 19 +- src/core/MOM_dynamics_split_RK2.F90 | 88 ++- src/core/MOM_forcing_type.F90 | 40 +- .../vertical/MOM_CVMix_KPP.F90 | 288 +++++++-- .../vertical/MOM_vert_friction.F90 | 583 +++++++----------- src/user/MOM_wave_interface.F90 | 2 +- 8 files changed, 552 insertions(+), 476 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index 9f409a1af9..897491711f 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -325,7 +325,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, & cfc=CS%use_CFC, marbl=CS%use_marbl_tracers, hevap=CS%enthalpy_cpl, & tau_mag=.true., ice_ncat=IOB%ice_ncat) - !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) + call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_nir_dir,isd,ied,jsd,jed) @@ -762,7 +762,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - !call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) if (CS%rigid_sea_ice) then call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -923,7 +923,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) - !forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) + forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. diff --git a/pkg/CVMix-src b/pkg/CVMix-src index 52aac958e0..3ec78bac83 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit 52aac958e05cdb2471dc73f9ef7fb4e816c550f2 +Subproject commit 3ec78bac8306ef2e61a33e0c4beafa0875a2c787 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2cbbf6bcc7..1c94cf18fb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -78,6 +78,7 @@ module MOM use MOM_dynamics_split_RK2, only : step_MOM_dyn_split_RK2, register_restarts_dyn_split_RK2 use MOM_dynamics_split_RK2, only : initialize_dyn_split_RK2, end_dyn_split_RK2 use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS, remap_dyn_split_rk2_aux_vars +use MOM_dynamics_split_RK2, only : init_dyn_split_RK2_diabatic use MOM_dynamics_split_RK2b, only : step_MOM_dyn_split_RK2b, register_restarts_dyn_split_RK2b use MOM_dynamics_split_RK2b, only : initialize_dyn_split_RK2b, end_dyn_split_RK2b use MOM_dynamics_split_RK2b, only : MOM_dyn_split_RK2b_CS, remap_dyn_split_RK2b_aux_vars @@ -2102,6 +2103,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: symmetric ! If true, use symmetric memory allocation. logical :: save_IC ! If true, save the initial conditions. logical :: do_unit_tests ! If true, call unit tests. + logical :: fpmix ! Needed to decide if BLD should be passed to RK2. logical :: test_grid_copy = .false. logical :: bulkmixedlayer ! If true, a refined bulk mixed layer scheme is used @@ -2206,6 +2208,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default=.false.) endif + ! FPMIX is needed to decide if boundary layer depth should be passed to RK2 + call get_param(param_file, '', "FPMIX", fpmix, & + "If true, add non-local momentum flux increments and diffuse down the Eulerian gradient.", & + default=.false., do_not_log=.true.) + + if (fpmix .and. .not. CS%split) then + call MOM_error(FATAL, "initialize_MOM: "//& + "FPMIX=True only works when SPLIT=True.") + endif + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", semi_Boussinesq, & @@ -3334,6 +3346,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) endif + ! GMM, the following is needed to get BLDs into the dynamics module + if (CS%split .and. fpmix) then + call init_dyn_split_RK2_diabatic(CS%diabatic_CSp, CS%dyn_split_RK2_CSp) + endif + if (associated(CS%sponge_CSp)) & call init_sponge_diags(Time, G, GV, US, diag, CS%sponge_CSp) @@ -3609,7 +3626,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) ! hML is needed when using the ice shelf module call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) - if (use_ice_shelf) then + if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & "Mixed layer thickness", "m", conversion=US%Z_to_m) endif diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 35e9c2722e..217ec42c20 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -12,6 +12,7 @@ module MOM_dynamics_split_RK2 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member use MOM_diag_mediator, only : diag_mediator_init, enable_averages use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u @@ -45,7 +46,9 @@ module MOM_dynamics_split_RK2 use MOM_continuity, only : continuity_init, continuity_stencil use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_debugging, only : check_redundant +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS, hor_visc_vel_stencil @@ -137,14 +140,16 @@ module MOM_dynamics_split_RK2 real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure - real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean - !! to the seafloor [R L Z T-2 ~> Pa] - real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean - !! to the seafloor [R L Z T-2 ~> Pa] - type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the - !! effective summed open face areas as a function - !! of barotropic flow. + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. ! This is to allow the previous, velocity-based coupling with between the ! baroclinic and barotropic modes. @@ -174,13 +179,13 @@ module MOM_dynamics_split_RK2 !! the extent to which the treatment of gravity waves !! is forward-backward (0) or simulated backward !! Euler (1) [nondim]. 0 is often used. - logical :: debug !< If true, write verbose checksums for debugging purposes. + real :: Cemp_NL !< Empirical coefficient of non-local momentum mixing [nondim] + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. + logical :: fpmix !< If true, add non-local momentum flux increments and diffuse down the Eulerian gradient. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. !>@{ Diagnostic IDs - integer :: id_uold = -1, id_vold = -1 integer :: id_uh = -1, id_vh = -1 integer :: id_umo = -1, id_vmo = -1 integer :: id_umo_2d = -1, id_vmo_2d = -1 @@ -267,6 +272,7 @@ module MOM_dynamics_split_RK2 public register_restarts_dyn_split_RK2 public initialize_dyn_split_RK2 public remap_dyn_split_RK2_aux_vars +public init_dyn_split_RK2_diabatic public end_dyn_split_RK2 !>@{ CPU time clock IDs @@ -394,7 +400,8 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f logical :: Use_Stokes_PGF ! If true, add Stokes PGF to hydrostatic PGF !---For group halo pass logical :: showCallTree, sym - + logical :: lFPpost ! Used to only post diagnostics in vertFPmix when fpmix=true and + ! in the corrector step (not the predict) integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_stencil, obc_stencil, vel_stencil @@ -710,16 +717,22 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC, VarMix) - call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & - GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (CS%fpmix) then hbl(:,:) = 0.0 - if (associated(visc%h_ML)) hbl(:,:) = visc%h_ML(:,:) - call vertFPmix(up, vp, uold, vold, hbl, h, forces, & - dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & - GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + + ! lFPpost must be false in the predictor step to avoid averaging into the diagnostics + lFPpost = .false. + call vertFPmix(up, vp, uold, vold, hbl, h, forces, dt_pred, lFPpost, CS%Cemp_NL, & + G, GV, US, CS%vertvisc_CSp, CS%OBC, waves=waves) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves) + else + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) endif if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") @@ -960,12 +973,15 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) - call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & - CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (CS%fpmix) then - call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & - G, GV, US, CS%vertvisc_CSp, CS%OBC) + lFPpost = .true. + call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, lFPpost, CS%Cemp_NL, & + G, GV, US, CS%vertvisc_CSp, CS%OBC, Waves=Waves) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, fpmix=CS%fpmix, waves=waves) + + else call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) endif @@ -1052,11 +1068,6 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f CS%CAu_pred_stored = .false. endif - if (CS%fpmix) then - if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) - if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) - endif - ! The time-averaged free surface height has already been set by the last call to btstep. ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH @@ -1290,6 +1301,17 @@ subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_ end subroutine remap_dyn_split_RK2_aux_vars +!> Initializes aspects of the dyn_split_RK2 that depend on diabatic processes. +!! Needed when BLDs are used in the dynamics. +subroutine init_dyn_split_RK2_diabatic(diabatic_CSp, CS) + type(diabatic_CS), intent(in) :: diabatic_CSp !< diabatic structure + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + +end subroutine init_dyn_split_RK2_diabatic + !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & @@ -1402,8 +1424,13 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p "timestep for use in the predictor step of the next split RK2 timestep.", & default=.true.) call get_param(param_file, mdl, "FPMIX", CS%fpmix, & - "If true, apply profiles of momentum flux magnitude and "//& - " direction", default=.false.) + "If true, add non-local momentum flux increments and diffuse down the Eulerian gradient.", & + default=.false.) + if (CS%fpmix) then + call get_param(param_file, "MOM", "CEMP_NL", CS%Cemp_NL, & + "Empirical coefficient of non-local momentum mixing.", & + units="nondim", default=3.6) + endif call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& "variables that are needed to reproduce across restarts, similarly to "//& @@ -1480,7 +1507,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, p call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) - call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, ntrunc, CS%vertvisc_CSp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp, CS%fpmix) CS%set_visc_CSp => set_visc call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, activate=is_new_run(restart_CS) ) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index bef29ffe86..d25df710ce 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -81,7 +81,7 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & - !omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect + omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, !! including any contributions from sub-gridscale variability @@ -263,8 +263,8 @@ module MOM_forcing_type tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, including any !! contributions from sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. - net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] - !omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + net_mass_src => NULL(), & !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) @@ -408,7 +408,7 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 - !integer :: id_omega_w2x = -1 + integer :: id_omega_w2x = -1 integer :: id_tau_mag = -1 integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 @@ -1577,8 +1577,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) - !handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & - ! 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') if (present(use_berg_fluxes)) then if (use_berg_fluxes) then @@ -2509,11 +2509,11 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif - !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then - ! do j=js,je ; do i=is,ie - ! fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) - ! enddo ; enddo - !endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) + enddo ; enddo + endif if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = forces%tau_mag(i,j) @@ -2661,11 +2661,11 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) forces%ustar(i,j) = fluxes%ustar(i,j) enddo ; enddo endif - !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then - ! do j=js,je ; do i=is,ie - ! forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) - ! enddo ; enddo - !endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + enddo ; enddo + endif if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then do j=js,je ; do i=is,ie forces%tau_mag(i,j) = fluxes%tau_mag(i,j) @@ -3367,8 +3367,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) - !if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & - ! call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -3748,7 +3748,7 @@ end subroutine myAlloc_3d subroutine deallocate_forcing_type(fluxes) type(forcing), intent(inout) :: fluxes !< Forcing fields structure - !if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) + if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) if (associated(fluxes%ustar)) deallocate(fluxes%ustar) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) if (associated(fluxes%tau_mag)) deallocate(fluxes%tau_mag) @@ -3821,7 +3821,7 @@ end subroutine deallocate_forcing_type subroutine deallocate_mech_forcing(forces) type(mech_forcing), intent(inout) :: forces !< Forcing fields structure - !if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) + if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index fec7219e7d..816d5d7498 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -30,6 +30,7 @@ module MOM_CVMix_KPP use CVMix_kpp, only : CVMix_kpp_compute_unresolved_shear use CVMix_kpp, only : CVMix_kpp_params_type use CVMix_kpp, only : CVMix_kpp_compute_kOBL_depth +use CVMix_kpp, only : CVMix_kpp_compute_StokesXi implicit none ; private @@ -82,6 +83,7 @@ module MOM_CVMix_KPP logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number character(len=32) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + logical :: StokesMOST !< If True, use Stokes similarity package logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity @@ -145,11 +147,15 @@ module MOM_CVMix_KPP integer :: id_EnhW = -1 integer :: id_La_SL = -1 integer :: id_OBLdepth_original = -1 + integer :: id_StokesXI = -1 + integer :: id_Lam2 = -1 !>@} ! Diagnostics arrays real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [Z ~> m] real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [Z ~> m] without smoothing + real, allocatable, dimension(:,:) :: StokesParXI !< Stokes similarity parameter + real, allocatable, dimension(:,:) :: Lam2 !< La^(-2) = Ustk0/u* real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [Z ~> m] real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] @@ -272,6 +278,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Type of interpolation to compute diff and visc at OBL_depth.\n'// & 'Allowed types are: linear, quadratic, cubic or LMD94.', & default='LMD94') + call get_param(paramFile, mdl, 'STOKES_MOST', CS%StokesMOST, & + 'If True, use Stokes Similarity package.', & + default=.False.) call get_param(paramFile, mdl, 'COMPUTE_EKMAN', CS%computeEkman, & 'If True, limit OBL depth to be no deeper than Ekman depth.', & default=.False.) @@ -498,6 +507,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) interp_type=CS%interpType, & interp_type2=CS%interpType2, & lEkman=CS%computeEkman, & + lStokesMOST=CS%StokesMOST, & lMonOb=CS%computeMoninObukhov, & MatchTechnique=CS%MatchTechnique, & lenhanced_diff=CS%enhance_diffusion,& @@ -524,6 +534,12 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') endif + if( CS%StokesMOST ) then + CS%id_StokesXI = register_diag_field('ocean_model', 'StokesXI', diag%axesT1, Time, & + 'Stokes Similarity Parameter', 'nondim') + CS%id_Lam2 = register_diag_field('ocean_model', 'Lam2', diag%axesT1, Time, & + 'Ustk0_ustar', 'nondim') + endif CS%id_BulkDrho = register_diag_field('ocean_model', 'KPP_BulkDrho', diag%axesTL, Time, & 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', & 'kg/m3', conversion=US%R_to_kg_m3) @@ -584,6 +600,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) allocate( CS%N( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%StokesParXI( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%Lam2 ( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%kOBL( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%La_SL( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%Vt2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) @@ -804,6 +822,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & GV%ke, & ! (in) Number of levels to compute coeffs for GV%ke, & ! (in) Number of levels in array shape Langmuir_EFactor=LangEnhK,& ! Langmuir enhancement multiplier + StokesXi = CS%StokesParXI(i,j), & ! Stokes forcing parameter CVMix_kpp_params_user=CS%KPP_params ) ! safety check, Kviscosity and Kdiffusivity must be >= 0 @@ -962,7 +981,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] - ! Variables for passing to CVMix routines, often in MKS units real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] @@ -997,6 +1015,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] real :: hTot ! Running sum of thickness used in the surface layer average [Z ~> m] + real :: I_hTot ! The inverse of hTot [Z-1 ~> m-1] real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] real :: delH ! Thickness of a layer [Z ~> m] real :: surfTemp ! Average of temperature over the surface layer [C ~> degC] @@ -1018,6 +1037,17 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl integer :: i, j, k, km1, kk, ksfc, ktmp ! Loop indices + real, dimension(GV%ke) :: uE_H, vE_H ! Eulerian velocities h-points, centers [L T-1 ~> m s-1] + real, dimension(GV%ke) :: uS_H, vS_H ! Stokes drift components h-points, centers [L T-1 ~> m s-1] + real, dimension(GV%ke) :: uSbar_H, vSbar_H ! Cell Average Stokes drift h-points [L T-1 ~> m s-1] + real, dimension(GV%ke+1) :: uS_Hi, vS_Hi ! Stokes Drift components at interfaces [L T-1 ~> m s-1] + real :: uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD ! Stokes at/to to Surface Layer Extent + ! [L T-1 ~> m s-1] + real :: StokesXI ! Stokes similarity parameter [nondim] + real, dimension( GV%ke ) :: StokesXI_1d , StokesVt_1d ! Parameters of TKE production ratio [nondim] + real :: Llimit ! Stable boundary Layer Limit = vonk Lstar [Z ~> m] + integer :: kbl ! index of cell containing boundary layer depth + if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") @@ -1046,27 +1076,36 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & - !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & + !$OMP surfHvS, hTot, I_hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & !$OMP deltarho, deltaBuoy, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & - !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & + !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset, uE_H, vE_H, & + !$OMP uS_H, vS_H, uSbar_H, vSbar_H , uS_Hi, vS_Hi, & + !$OMP uS_SLD, vS_SLD, uS_SLC, vS_SLC, uSbar_SLD, vSbar_SLD, & + !$OMP StokesXI, StokesXI_1d, StokesVt_1d, kbl) & !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then do k=1,GV%ke - U_H(k) = 0.5 * (u(i,j,k)+u(i-1,j,k)) - V_H(k) = 0.5 * (v(i,j,k)+v(i,j-1,k)) + U_H(k) = 0.5 * (u(I,j,k)+u(I-1,j,k)) + V_H(k) = 0.5 * (v(i,J,k)+v(i,J-1,k)) enddo + if (CS%StokesMOST) then + do k=1,GV%ke + uE_H(k) = 0.5 * (u(I,j,k)+u(I-1,j,k)-Waves%US_x(I,j,k)-Waves%US_x(I-1,j,k)) + vE_H(k) = 0.5 * (v(i,J,k)+v(i,J-1,k)-Waves%US_y(i,J,k)-Waves%US_y(i,J-1,k)) + enddo + endif ! things independent of position within the column Coriolis = 0.25*US%s_to_T*( (G%CoriolisBu(i,j) + G%CoriolisBu(i-1,j-1)) + & (G%CoriolisBu(i-1,j) + G%CoriolisBu(i,j-1)) ) surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) - ! Bullk Richardson number computed for each cell in a column, + ! Bulk Richardson number computed for each cell in a column, ! assuming OBLdepth = grid cell depth. After Rib(k) is ! known for the column, then CVMix interpolates to find ! the actual OBLdepth. This approach avoids need to iterate @@ -1075,8 +1114,11 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl iFaceHeight(1) = 0.0 ! BBL is all relative to the surface pRef = 0. ; if (associated(tv%p_surf)) pRef = tv%p_surf(i,j) hcorr = 0. - do k=1,GV%ke + if (CS%StokesMOST) call Compute_StokesDrift( i, j, h(i,j,1) , iFaceHeight(1), & + uS_Hi(1), vS_Hi(1), uS_H(1), vS_H(1), uSbar_H(1), vSbar_H(1), Waves) + + do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) @@ -1095,53 +1137,99 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl endif enddo - ! average temperature, salinity, u and v over surface layer - ! use C-grid average to get u and v on T-points. - surfHtemp = 0.0 - surfHsalt = 0.0 - surfHu = 0.0 - surfHv = 0.0 - surfHuS = 0.0 - surfHvS = 0.0 - hTot = 0.0 - do ktmp = 1,ksfc - - ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) - - ! surface layer thickness - hTot = hTot + delH - - ! surface averaged fields - surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH - surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH - surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH - surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%StokesMOST) then + surfBuoyFlux = buoy_scale * & + (buoyFlux(i,j,1) - 0.5*(buoyFlux(i,j,k)+buoyFlux(i,j,k+1)) ) + surfBuoyFlux2(k) = surfBuoyFlux + call Compute_StokesDrift(i,j, iFaceHeight(k),iFaceHeight(k+1), & + uS_Hi(k+1), vS_Hi(k+1), uS_H(k), vS_H(k), uSbar_H(k), vSbar_H(k), Waves) + call Compute_StokesDrift(i,j, iFaceHeight(ksfc) , -SLdepth_0d, & + uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD, Waves) + call cvmix_kpp_compute_StokesXi( iFaceHeight,CellHeight,ksfc ,SLdepth_0d,surfBuoyFlux, & + surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, vS_Hi, uSbar_H, vSbar_H, uS_SLD,& + vS_SLD, uSbar_SLD, vSbar_SLD, StokesXI, CVMix_kpp_params_user=CS%KPP_params ) + StokesXI_1d(k) = StokesXI + StokesVt_1d(k) = StokesXI + + ! average temperature, salinity, u and v over surface layer starting at ksfc + delH = SLdepth_0d + iFaceHeight(ksfc-1) + surfHtemp = Temp(i,j,ksfc) * delH + surfHsalt = Salt(i,j,ksfc) * delH + surfHu = (uE_H(ksfc) + uSbar_SLD) * delH + surfHv = (vE_H(ksfc) + vSbar_SLD) * delH + hTot = delH + do ktmp = 1,ksfc-1 ! if ksfc >=2 + delH = h(i,j,ktmp)*GV%H_to_Z + hTot = hTot + delH + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + (uE_H(ktmp) + uSbar_H(ktmp)) * delH + surfHv = surfHv + (vE_H(ktmp) + vSbar_H(ktmp)) * delH + enddo + I_hTot = 1./hTot + surfTemp = surfHtemp * I_hTot + surfSalt = surfHsalt * I_hTot + surfU = surfHu * I_hTot + surfV = surfHv * I_hTot + Uk = uE_H(k) + uS_H(k) - surfU + Vk = vE_H(k) + vS_H(k) - surfV + + else !not StokesMOST + StokesXI_1d(k) = 0.0 + + ! average temperature, salinity, u and v over surface layer + ! use C-grid average to get u and v on T-points. + surfHtemp = 0.0 + surfHsalt = 0.0 + surfHu = 0.0 + surfHv = 0.0 + surfHuS = 0.0 + surfHvS = 0.0 + hTot = 0.0 + do ktmp = 1,ksfc + + ! SLdepth_0d can be between cell interfaces + delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) + + ! surface layer thickness + hTot = hTot + delH + + ! surface averaged fields + surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH + surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH + surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH + surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + if (CS%Stokes_Mixing) then + surfHus = surfHus + 0.5*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + endif + + enddo + surfTemp = surfHtemp / hTot + surfSalt = surfHsalt / hTot + surfU = surfHu / hTot + surfV = surfHv / hTot + surfUs = surfHus / hTot + surfVs = surfHvs / hTot + + ! vertical shear between present layer and surface layer averaged surfU and surfV. + ! C-grid average to get Uk and Vk on T-points. + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV + if (CS%Stokes_Mixing) then - surfHus = surfHus + 0.5*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH - surfHvs = surfHvs + 0.5*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + ! If momentum is mixed down the Stokes drift gradient, then + ! the Stokes drift must be included in the bulk Richardson number + ! calculation. + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) endif - enddo - surfTemp = surfHtemp / hTot - surfSalt = surfHsalt / hTot - surfU = surfHu / hTot - surfV = surfHv / hTot - surfUs = surfHus / hTot - surfVs = surfHvs / hTot - - ! vertical shear between present layer and surface layer averaged surfU and surfV. - ! C-grid average to get Uk and Vk on T-points. - Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV - - if (CS%Stokes_Mixing) then - ! If momentum is mixed down the Stokes drift gradient, then - ! the Stokes drift must be included in the bulk Richardson number - ! calculation. - Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) - Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) - endif + ! this difference accounts for penetrating SW + surfBuoyFlux = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) + surfBuoyFlux2(k) = surfBuoyFlux + + endif ! StokesMOST deltaU2(k) = US%L_T_to_m_s**2 * (Uk**2 + Vk**2) @@ -1165,9 +1253,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! iterate pRef for next pass through k-loop. pRef = pRef + (GV%g_Earth * GV%H_to_RZ) * h(i,j,k) - ! this difference accounts for penetrating SW - surfBuoyFlux2(k) = buoy_scale * (buoyFlux(i,j,1) - buoyFlux(i,j,k+1)) - enddo ! k-loop finishes if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then @@ -1215,11 +1300,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass ! sigma=CS%surf_layer_ext for this calculation. - call CVMix_kpp_compute_turbulent_scales( & + call CVMix_kpp_compute_turbulent_scales( & ! 1d_OBL CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext OBL_depth, & ! (in) OBL depth [m] surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + xi=StokesVt_1d, & ! (in) Stokes similarity parameter-->1/CHI(xi) enhance of Vt w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params ) @@ -1255,10 +1341,17 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl N_iface=N_col, & ! Buoyancy frequency [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] - bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] + bfsfc=surfBuoyFlux2, & ! surface buoyancy flux [m2 s-3] uStar=surfFricVel, & ! surface friction velocity [m s-1] CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters +! ! A hack to avoid KPP reaching the bottom. It was needed during development +! ! because KPP was unable to handle vanishingly small layers near the bottom. +! if (CS%deepOBLoffset>0.) then +! zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) +! CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) +! endif + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(GV%ke+1)) call CVMix_kpp_compute_OBL_depth( & BulkRi_1d, & ! (in) Bulk Richardson number @@ -1267,11 +1360,39 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent zt_cntr=z_cell, & ! (in) Height of cell centers [m] surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + surf_buoy=surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] + Xi = StokesXI_1d, & ! (in) Stokes similarity parameter Lmob limit (1-Xi) + zBottom = zBottomMinusOffset, & ! (in) Numerical limit on OBLdepth CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters CS%OBLdepth(i,j) = US%m_to_Z * KPP_OBL_depth + if (CS%StokesMOST) then + kbl = nint(CS%kOBL(i,j)) + SLdepth_0d = CS%surf_layer_ext*CS%OBLdepth(i,j) + surfBuoyFlux = surfBuoyFlux2(kbl) + ! find ksfc for cell where "surface layer" sits + ksfc = kbl + do ktmp = 1, kbl + if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then + ksfc = ktmp + exit + endif + enddo + + call Compute_StokesDrift(i,j, iFaceHeight(ksfc) , -SLdepth_0d, & + uS_SLD , vS_SLD, uS_SLC , vS_SLC, uSbar_SLD, vSbar_SLD, Waves) + call cvmix_kpp_compute_StokesXi( iFaceHeight,CellHeight,ksfc ,SLdepth_0d, & + surfBuoyFlux, surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, & + vS_Hi, uSbar_H, vSbar_H, uS_SLD, vS_SLD, uSbar_SLD, vSbar_SLD, & + StokesXI, CVMix_kpp_params_user=CS%KPP_params ) + CS%StokesParXI(i,j) = StokesXI + CS%Lam2(i,j) = sqrt(US_Hi(1)**2+VS_Hi(1)**2) / MAX(surfFricVel,0.0002) + + else !.not Stokes_MOST + CS%StokesParXI(i,j) = 10.0 + CS%Lam2(i,j) = sqrt(US_Hi(1)**2+VS_Hi(1)**2) / MAX(surfFricVel,0.0002) + ! A hack to avoid KPP reaching the bottom. It was needed during development ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then @@ -1285,6 +1406,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) + endif !Stokes_MOST + ! compute unresolved squared velocity for diagnostics if (CS%id_Vt2 > 0) then Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & @@ -1293,7 +1416,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl N_iface=N_col, & ! Buoyancy frequency at interface [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] - bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] + bfsfc=surfBuoyFlux2, & ! surface buoyancy flux [m2 s-3] uStar=surfFricVel, & ! surface friction velocity [m s-1] CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters CS%Vt2(i,j,:) = US%m_to_Z*US%T_to_s * Vt2_1d(:) @@ -1307,6 +1430,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + xi=StokesXI, & ! (in) Stokes similarity parameter-->1/CHI(xi) enhance w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters CS%Ws(i,j,:) = US%m_to_Z*US%T_to_s*Ws_1d(:) @@ -1342,6 +1466,11 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_La_SL > 0) call post_data(CS%id_La_SL, CS%La_SL, CS%diag) if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) + if (CS%StokesMOST) then + if (CS%id_StokesXI > 0) call post_data(CS%id_StokesXI, CS%StokesParXI, CS%diag) + if (CS%id_Lam2 > 0) call post_data(CS%id_Lam2 , CS%Lam2 , CS%diag) + endif + ! BLD smoothing: if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, dz) @@ -1594,6 +1723,49 @@ subroutine KPP_NonLocalTransport_saln(CS, G, GV, h, nonLocalTrans, surfFlux, dt, end subroutine KPP_NonLocalTransport_saln +!> Compute Stokes Drift components at zbot < ztop <= 0 and at k=0.5*(ztop+zbot) and +!! average components from ztop to zbot <= 0 +subroutine Compute_StokesDrift(i ,j, ztop, zbot, uS_i, vS_i, uS_k, vS_k, uSbar, vSbar, waves) + + type(wave_parameters_CS), pointer :: waves !< Wave CS for Langmuir turbulence + real, intent(in) :: ztop !< cell top + real, intent(in) :: zbot !< cell bottom + real, intent(inout) :: uS_i !< Stokes u velocity at zbot interface + real, intent(inout) :: vS_i !< Stokes v velocity at zbot interface + real, intent(inout) :: uS_k !< Stokes u velocity at zk center + real, intent(inout) :: vS_k !< Stokes v at zk =0.5(ztop+zbot) + real, intent(inout) :: uSbar !< mean Stokes u (ztop to zbot) + real, intent(inout) :: vSbar !< mean Stokes v (ztop to zbot) + integer, intent(in) :: i !< Meridional index of H-point + integer, intent(in) :: j !< Zonal index of H-point + + ! local variables + integer :: b !< wavenumber band index + real :: fexp !< an exponential function + real :: WaveNum !< Wavenumber + + uS_i = 0.0 + vS_i = 0.0 + uS_k = 0.0 + vS_k = 0.0 + uSbar = 0.0 + vSbar = 0.0 + do b = 1, waves%NumBands + WaveNum = waves%WaveNum_Cen(b) + fexp = exp(2. * WaveNum * zbot) + uS_i = uS_i + waves%Ustk_Hb(i,j,b) * fexp + vS_i = vS_i + waves%Vstk_Hb(i,j,b) * fexp + fexp = exp( WaveNum * (ztop + zbot) ) + uS_k = uS_k+ waves%Ustk_Hb(i,j,b) * fexp + vS_k = vS_k+ waves%Vstk_Hb(i,j,b) * fexp + fexp = exp(2. * WaveNum * ztop) - exp(2. * WaveNum * zbot) + uSbar = uSbar + 0.5 * waves%Ustk_Hb(i,j,b) * fexp / WaveNum + vSbar = vSbar + 0.5 * waves%Vstk_Hb(i,j,b) * fexp / WaveNum + enddo + uSbar = uSbar / (ztop-zbot) + vSbar = vSbar / (ztop-zbot) + +end subroutine Compute_StokesDrift !> Clear pointers, deallocate memory subroutine KPP_end(CS) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index c26ee4ac75..3f968b2101 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -31,6 +31,8 @@ module MOM_vert_friction use MOM_set_visc, only : set_v_at_u, set_u_at_v use MOM_lateral_mixing_coeffs, only : VarMix_CS +use CVMix_kpp, only : cvmix_kpp_composite_Gshape + implicit none ; private #include @@ -170,9 +172,11 @@ module MOM_vert_friction integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 - integer :: id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 - integer :: id_tauFP_u = -1, id_tauFP_v = -1 !W, id_FPtau2x_u = -1, id_FPtau2x_v = -1 - integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 + integer :: id_Omega_w2x = -1, id_FPtau2s = -1 , id_FPtau2w = -1 + integer :: id_uE_h = -1, id_vE_h = -1 + integer :: id_uStk = -1, id_vStk = -1 + integer :: id_uStk0 = -1, id_vStk0 = -1 + integer :: id_uInc_h= -1, id_vInc_h= -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 integer :: id_Kv_gl90_u = -1, id_Kv_gl90_v = -1 @@ -191,392 +195,211 @@ module MOM_vert_friction contains -!> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. -subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) +!> Add nonlocal stress increments to ui^n and vi^n. +subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G, GV, US, CS, OBC, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] + intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: hbl_h !< boundary layer depth [H ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment [T ~> s] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + real, intent(in) :: Cemp_NL !< empirical coefficient of non-local momentum mixing [nondim] + logical, intent(in) :: lpost !< Compute and make available FPMix diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(wave_parameters_CS), & + optional, pointer :: Waves !< Container for wave/Stokes information ! local variables - real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] - real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth at v-pts [H ~> m] - integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u !< index of the BLD at u-pts [nondim] - integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v !< index of the BLD at v-pts [nondim] - real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u !< ustar squared at u-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v !< ustar squared at v-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< zonal wind stress at u-pts [R L Z T-2 ~> Pa] - real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< meridional wind stress at v-pts [R L Z T-2 ~> Pa] - !real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] - !real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !< kinematic zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v !< kinematic mer. mtm flux at v-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u !< downgradient zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u !< downgradient meri mtm flux at u-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v !< downgradient zonal mtm flux at v-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v !< downgradient meri mtm flux at v-pts [L2 T-2 ~> m2 s-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u !< angle between mtm flux and vert shear at u-pts [rad] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v !< angle between mtm flux and vert shear at v-pts [rad] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u !< angle between mtm flux and wind at u-pts [rad] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v !< angle between mtm flux and wind at v-pts [rad] - - real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp !< constants and dummy variables [nondim] - real :: omega_tmp !< A dummy angle [radians] - real :: du, dv !< Velocity increments [L T-1 ~> m s-1] - real :: depth !< Cumulative layer thicknesses [H ~> m or kg m=2] - real :: sigma !< Fractional depth in the mixed layer [nondim] - real :: Wind_x, Wind_y !< intermediate wind stress componenents [L2 T-2 ~> m2 s-2] - real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables [L2 T-2 ~> m2 s-2] - real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables [L2 T-2 ~> m2 s-2] - real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles [radians] - integer :: kblmin, kbld, kp1, k, nz !< vertical indices - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth (u-pts) [H ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth (v-pts) [H ~> m] + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< kinematic zonal wind stress (u-pts) [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< kinematic merid wind stress (v-pts) [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: uS0 !< surface zonal Stokes drift [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G)) :: vS0 !< surface zonal Stokes drift [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uE_u !< zonal Eulerian u-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uE_h !< zonal Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vE_v !< merid Eulerian v-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vE_h !< merid Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uInc_u !< zonal Eulerian u-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uInc_h !< zonal Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vInc_v !< merid Eulerian v-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vInc_h !< merid Eulerian h-pts [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: uStk !< zonal Stokes Drift (h-pts) [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)) :: vStk !< merid Stokes Drift (h-pts) [L T-1 ~> m s-1] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)+1) :: omega_tau2s !< angle stress to shear (h-pts) [rad] + real, dimension(SZI_(G) ,SZJ_(G),SZK_(GV)+1) :: omega_tau2w !< angle stress to wind (h-pts) [rad] + real :: pi, tmp_u, tmp_v, omega_tmp, Irho0, fexp !< constants and dummy variables + real :: sigma,Gat1,Gsig,dGdsig !< Shape parameters + real :: du, dv, depth, Wind_x, Wind_y !< intermediate variables + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, ustar2min, tauh !< intermediate variables + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables + real :: omega_w2s, omega_s2x, omega_tau2x, omega_s2w , omega_e2x, omega_l2x !< intermediate angles + integer :: b, kbld, kp1, k, nz !< band and vertical indices + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq !< horizontal indices is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke pi = 4. * atan2(1.,1.) - Cemp_CG = 3.6 - kblmin = 1 - taux_u(:,:) = 0. - tauy_v(:,:) = 0. + Irho0 = 1.0 / GV%Rho0 - do j = js,je - do I = Isq,Ieq - taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ !W rho0=1035. - enddo - enddo - - do J = Jsq,Jeq - do i = is,ie - tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ - enddo - enddo + call pass_var(hbl_h , G%Domain, halo=1) - call pass_var( hbl_h ,G%Domain, halo=1 ) - call pass_vector(taux_u , tauy_v, G%Domain, To_All ) - ustar2_u(:,:) = 0. - ustar2_v(:,:) = 0. - hbl_u(:,:) = 0. - hbl_v(:,:) = 0. - kbl_u(:,:) = 0 - kbl_v(:,:) = 0 - !omega_w2x_u(:,:) = 0.0 - !omega_w2x_v(:,:) = 0.0 - tauxDG_u(:,:,:) = 0.0 - tauyDG_v(:,:,:) = 0.0 + ! u-points do j = js,je do I = Isq,Ieq - if( (G%mask2dCu(I,j) > 0.5) ) then - tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) - hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j) * hbl_h(i+1,j)) /tmp - tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) - tauy = ( G%mask2dCv(i ,j )*tauy_v(i ,j ) + G%mask2dCv(i ,j-1)*tauy_v(i ,j-1) & - + G%mask2dCv(i+1,j )*tauy_v(i+1,j ) + G%mask2dCv(i+1,j-1)*tauy_v(i+1,j-1) ) / tmp - ustar2_u(I,j) = sqrt( taux_u(I,j)*taux_u(I,j) + tauy*tauy ) - !omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) - tauxDG_u(I,j,1) = taux_u(I,j) - depth = 0.0 - do k = 1, nz - depth = depth + CS%h_u(I,j,k) - if( (depth >= hbl_u(I,j)) .and. (kbl_u(I,j) == 0 ) .and. (k > (kblmin-1)) ) then - kbl_u(I,j) = k - hbl_u(I,j) = depth - endif - enddo + taux_u(I,j) = forces%taux(I,j) * Irho0 + if ( (G%mask2dCu(I,j) > 0.5) ) then + ! h to u-pts + tmp_u = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j) * hbl_h(i+1,j)) / tmp_u endif + depth = 0. + Gat1 = 0. + do k=1, nz + ! cell center + depth = depth + 0.5*CS%h_u(I,j,k) + uE_u(I,j,k) = ui(I,j,k) - waves%Us_x(I,j,k) + if ( depth < hbl_u(I,j) ) then + sigma = depth / hbl_u(i,j) + ! cell bottom + depth = depth + 0.5*CS%h_u(I,j,k) + call cvmix_kpp_composite_Gshape(sigma,Gat1,Gsig,dGdsig) + ! nonlocal boundary-layer increment + uInc_u(I,j,k) = dt * Cemp_NL * taux_u(I,j) * dGdsig / hbl_u(I,j) + ui(I,j,k) = ui(I,j,k) + uInc_u(I,j,k) + else + uInc_u(I,j,k) = 0.0 + endif + enddo enddo enddo + + ! v-points do J = Jsq,Jeq do i = is,ie - if( (G%mask2dCv(i,J) > 0.5) ) then - tmp = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) - hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp - tmp = max(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1))) - taux = ( G%mask2dCu(i ,j) * taux_u(i ,j) + G%mask2dCu(i ,j+1) * taux_u(i ,j+1) & - + G%mask2dCu(i-1,j) * taux_u(i-1,j) + G%mask2dCu(i-1,j+1) * taux_u(i-1,j+1)) / tmp - ustar2_v(i,J) = sqrt(tauy_v(i,J)*tauy_v(i,J) + taux*taux) - !omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) - tauyDG_v(i,J,1) = tauy_v(i,J) - depth = 0.0 - do k = 1, nz - depth = depth + CS%h_v(i,J,k) - if( (depth >= hbl_v(i,J)) .and. (kbl_v(i,J) == 0) .and. (k > (kblmin-1))) then - kbl_v(i,J) = k - hbl_v(i,J) = depth - endif - enddo + tauy_v(i,J) = forces%tauy(i,J) * Irho0 + if ( (G%mask2dCv(i,J) > 0.5) ) then + ! h to v-pts + tmp_v = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) + hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) / tmp_v endif - enddo - enddo - - if (CS%debug) then - !### These checksum calls are missing necessary dimensional scaling factors. - call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) - call uvchksum("ustar2", ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) - call uvchksum(" hbl", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) - endif - - ! Compute downgradient stresses - do k = 1, nz - kp1 = min( k+1 , nz) - do j = js ,je - do I = Isq , Ieq - tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp1) * (ui(I,j,k) - ui(I,j,kp1)) - enddo - enddo - do J = Jsq , Jeq - do i = is , ie - tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp1) * (vi(i,J,k) - vi(i,J,kp1)) - enddo - enddo - enddo - - call pass_vector(tauxDG_u, tauyDG_v , G%Domain, To_All) - call pass_vector(ui,vi, G%Domain, To_All) - tauxDG_v(:,:,:) = 0. - tauyDG_u(:,:,:) = 0. - - ! Thickness weighted interpolations - do k = 1, nz - ! v to u points - do j = js , je - do I = Isq, Ieq - tauyDG_u(I,j,k) = set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) - enddo - enddo - ! u to v points - do J = Jsq, Jeq - do i = is, ie - tauxDG_v(i,J,k) = set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) + depth = 0. + Gat1 = 0. + do k=1, nz + ! cell center + depth = depth + 0.5* CS%h_v(i,J,k) + vE_v(i,J,k) = vi(i,J,k) - waves%Us_y(i,J,k) + if ( depth < hbl_v(i,J) ) then + sigma = depth / hbl_v(i,J) + ! cell bottom + depth = depth + 0.5* CS%h_v(i,J,k) + call cvmix_kpp_composite_Gshape(sigma,Gat1,Gsig,dGdsig) + ! nonlocal boundary-layer increment + vInc_v(i,J,k) = dt * Cemp_NL * tauy_v(i,J) * dGdsig / hbl_v(i,J) + vi(i,J,k) = vi(i,J,k) + vInc_v(i,J,k) + else + vInc_v(i,J,k) = 0.0 + endif enddo enddo enddo - if (CS%debug) then - call uvchksum(" tauyDG_u tauxDG_v",tauyDG_u,tauxDG_v, G%HI, haloshift=0, scalar_pair=.true.) - endif - ! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2w_[u,v] and stress mag tau_[u,v] - omega_tau2w_u(:,:,:) = 0.0 - omega_tau2w_v(:,:,:) = 0.0 - omega_tau2s_u(:,:,:) = 0.0 - omega_tau2s_v(:,:,:) = 0.0 - tau_u(:,:,:) = 0.0 - tau_v(:,:,:) = 0.0 - - ! stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] - do j = js,je - do I = Isq,Ieq - if( (G%mask2dCu(I,j) > 0.5) ) then - ! SURFACE - tauyDG_u(I,j,1) = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) - tau_u(I,j,1) = ustar2_u(I,j) - Omega_tau2w_u(I,j,1) = 0.0 - Omega_tau2s_u(I,j,1) = 0.0 + ! Compute and store diagnostics, only during the corrector step. + if (lpost) then + call pass_vector(uE_u , vE_v , G%Domain, To_All) + call pass_vector(uInc_u, vInc_v , G%Domain, To_All) + uStk = 0.0 + vStk = 0.0 + uS0 = 0.0 + vS0 = 0.0 + + do j = js,je + do i = is,ie + if (G%mask2dT(i,j) > 0.5) then + ! u to h-pts + tmp_u = max( 1.0 ,(G%mask2dCu(i,j) + G%mask2dCu(i-1,j))) + ! v to h-pts + tmp_v = max( 1.0 ,(G%mask2dCv(i,j) + G%mask2dCv(i,j-1))) + do k = 1,nz + uE_h(i,j,k) = (G%mask2dCu(i,j) * uE_u(i,j,k) + G%mask2dCu(i-1,j) * uE_u(i-1,j,k)) / tmp_u + uInc_h(i,j,k) = (G%mask2dCu(i,j) * uInc_u(i,j,k) + G%mask2dCu(i-1,j) * uInc_u(i-1,j,k)) / tmp_u + vE_h(i,j,k) = (G%mask2dCv(i,j) * vE_v(i,j,k) + G%mask2dCv(i,j-1) * vE_v(i,j-1,k)) / tmp_v + vInc_h(i,j,k) = (G%mask2dCv(i,j) * vInc_v(i,j,k) + G%mask2dCv(i,j-1) * vInc_v(i,j-1,k)) / tmp_v + enddo + ! Wind, Stress and Shear align at surface + Omega_tau2w(i,j,1) = 0.0 + Omega_tau2s(i,j,1) = 0.0 + do k = 1,nz + kp1 = min( nz , k+1) + du = uE_h(i,j,k) - uE_h(i,j,kp1) + dv = vE_h(i,j,k) - vE_h(i,j,kp1) + omega_s2x = atan2( dv , du ) + + du = du + uInc_h(i,j,k) - uInc_h(i,j,kp1) + dv = dv + vInc_h(i,j,k) - vInc_h(i,j,kp1) + omega_tau2x = atan2( dv , du ) + + omega_tmp = omega_tau2x - forces%omega_w2x(i,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w(i,j,kp1) = omega_tmp + + omega_tmp = omega_tau2x - omega_s2x + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2s(i,j,kp1) = omega_tmp - do k=1,nz - kp1 = MIN(k+1 , nz) - tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) - Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) - omega_tmp = Omega_tau2x !- omega_w2x_u(I,j) - if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi - if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi - Omega_tau2w_u(I,j,k+1) = omega_tmp - Omega_tau2s_u(I,j,k+1) = 0.0 - enddo - endif - enddo - enddo - do J = Jsq, Jeq - do i = is, ie - if( (G%mask2dCv(i,J) > 0.5) ) then - ! SURFACE - tauxDG_v(i,J,1) = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) - tau_v(i,J,1) = ustar2_v(i,J) - Omega_tau2w_v(i,J,1) = 0.0 - Omega_tau2s_v(i,J,1) = 0.0 - - do k=1,nz-1 - kp1 = MIN(k+1 , nz) - tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) - omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) - omega_tmp = omega_tau2x !- omega_w2x_v(i,J) - if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi - if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi - Omega_tau2w_v(i,J,k+1) = omega_tmp - Omega_tau2s_v(i,J,k+1) = 0.0 - enddo - endif - enddo - enddo + enddo + endif - ! Parameterized stress orientation from the wind at interfaces (tau2x) - ! and centers (tau2x) OVERWRITE to kbl-interface above hbl - do j = js,je - do I = Isq,Ieq - if( (G%mask2dCu(I,j) > 0.5) ) then - kbld = min( (kbl_u(I,j)) , (nz-2) ) - if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 - - !### This expression is dimensionally inconsistent. - tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff - ! surface boundary conditions - depth = 0. - tauNLup = 0.0 - do k=1, kbld - depth = depth + CS%h_u(I,j,k) - sigma = min( 1.0 , depth / hbl_u(i,j) ) - - ! linear stress mag - tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) - !### The following expressions are dimensionally inconsistent. - cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) - sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) - - ! rotate to wind coordinates - Wind_x = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) - Wind_y = ustar2_u(I,j) !* sin(omega_w2x_u(I,j)) - tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) - tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) - omega_w2s = atan2(tauNL_CG, tauNL_DG) - omega_s2w = 0.0-omega_w2s - tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG - tau_MAG = max(tau_MAG, tauNL_CG) - tauNL_DG = sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) - tau_u(I,j,k+1) - - ! back to x,y coordinates - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) - tauNLdn = tauNL_X - - ! nonlocal increment and update to uold - !### The following expression is dimensionally inconsistent and missing parentheses. - du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) - ui(I,j,k) = uold(I,j,k) + du - uold(I,j,k) = du - tauNLup = tauNLdn - - ! diagnostics - Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG)) - tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2) - omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X)) - omega_tau2w = omega_tau2x !- omega_w2x_u(I,j) - if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi - if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi - Omega_tau2w_u(I,j,k+1) = omega_tau2w + ! Stokes drift + do b=1,waves%NumBands + uS0(i,j) = uS0(i,j) + waves%UStk_Hb(i,j,b) ! or forces%UStkb(i,j,b) + vS0(i,j) = vS0(i,j) + waves%VStk_Hb(i,j,b) ! or forces%VStkb(i,j,b) enddo - do k= kbld+1, nz - ui(I,j,k) = uold(I,j,k) - uold(I,j,k) = 0.0 + depth = 0.0 + do k = 1,nz + do b = 1, waves%NumBands + ! cell center + fexp = exp(-2. * waves%WaveNum_Cen(b) * (depth+0.5*h(i,j,k)) ) + uStk(i,j,k) = uStk(i,j,k) + waves%UStk_Hb(i,j,b) * fexp + vStk(i,j,k) = vStk(i,j,k) + waves%VStk_Hb(i,j,b) * fexp + enddo + ! cell bottom + depth = depth + h(i,j,k) enddo - endif + enddo enddo - enddo - ! v-point dv increment - do J = Jsq,Jeq - do i = is,ie - if( (G%mask2dCv(i,J) > 0.5) ) then - kbld = min((kbl_v(i,J)), (nz-2)) - if (tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1)) kbld = kbld + 1 - tauh = tau_v(i,J,kbld+1) - - !surface boundary conditions - depth = 0. - tauNLup = 0.0 - do k=1, kbld - depth = depth + CS%h_v(i,J,k) - sigma = min(1.0, depth/ hbl_v(I,J)) - - ! linear stress - tau_MAG = (ustar2_v(i,J) * (1.-sigma)) + (tauh * sigma) - !### The following expressions are dimensionally inconsistent. - cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) - sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) - - ! rotate into wind coordinate - Wind_x = ustar2_v(i,J) !* cos(omega_w2x_v(i,J)) - Wind_y = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) - tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) - tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) - omega_w2s = atan2(tauNL_CG , tauNL_DG) - omega_s2w = 0.0 - omega_w2s - tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG - tau_MAG = max( tau_MAG , tauNL_CG ) - tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) - - ! back to x,y coordinate - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) - tauNLdn = tauNL_Y - !### The following expression is dimensionally inconsistent, [L T-1] vs. [L2 H-1 T-1] on the right, - ! and it is inconsistent with the counterpart expression for du. - dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) - vi(i,J,k) = vold(i,J,k) + dv - vold(i,J,k) = dv - tauNLup = tauNLdn - - ! diagnostics - Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG) - tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2) - !omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) - !omega_tau2w = omega_tau2x - omega_w2x_v(i,J) - if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi - if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi - Omega_tau2w_v(i,J,k+1) = omega_tau2w - enddo + ! post FPmix diagnostics + if (CS%id_uE_h > 0) call post_data(CS%id_uE_h , uE_h , CS%diag) + if (CS%id_vE_h > 0) call post_data(CS%id_vE_h , vE_h , CS%diag) + if (CS%id_uInc_h > 0) call post_data(CS%id_uInc_h , uInc_h , CS%diag) + if (CS%id_vInc_h > 0) call post_data(CS%id_vInc_h , vInc_h , CS%diag) + if (CS%id_FPtau2s > 0) call post_data(CS%id_FPtau2s, Omega_tau2s, CS%diag) + if (CS%id_FPtau2w > 0) call post_data(CS%id_FPtau2w, Omega_tau2w, CS%diag) + if (CS%id_uStk0 > 0) call post_data(CS%id_uStk0 , uS0 , CS%diag) + if (CS%id_vStk0 > 0) call post_data(CS%id_vStk0 , vS0 , CS%diag) + if (CS%id_uStk > 0) call post_data(CS%id_uStk , uStk , CS%diag) + if (CS%id_vStk > 0) call post_data(CS%id_vStk , vStk , CS%diag) + if (CS%id_Omega_w2x > 0) call post_data(CS%id_Omega_w2x, forces%omega_w2x, CS%diag) - do k= kbld+1, nz - vi(i,J,k) = vold(i,J,k) - vold(i,J,k) = 0.0 - enddo - endif - enddo - enddo - - if (CS%debug) then - call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) endif - if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) - if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) - if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) - if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) - if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) - if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) - !if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) - end subroutine vertFPmix -!> Returns the empirical shape-function given sigma [nondim] -real function G_sig(sigma) - real , intent(in) :: sigma !< Normalized boundary layer depth [nondim] - - ! local variables - real :: p1, c2, c3 !< Parameters used to fit and match empirical shape-functions [nondim] - - ! parabola - p1 = 0.287 - ! cubic function - c2 = 1.74392 - c3 = 2.58538 - G_sig = min( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) -end function G_sig - !> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb !! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme !! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, @@ -701,7 +524,7 @@ end subroutine find_coupling_coef_gl90 !! if DIRECT_STRESS is true, applied to the surface layer. subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & - taux_bot, tauy_bot, Waves) + taux_bot, tauy_bot, fpmix, Waves) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -725,6 +548,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real, dimension(SZI_(G),SZJB_(G)), & optional, intent(out) :: tauy_bot !< Meridional bottom stress from ocean to !! rock [R L Z T-2 ~> Pa] + logical, optional, intent(in) :: fpmix !< fpmix along Eulerian shear type(wave_parameters_CS), & optional, pointer :: Waves !< Container for wave/Stokes information @@ -765,6 +589,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & logical :: do_i(SZIB_(G)) logical :: DoStokesMixing + logical :: lfpmix integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec @@ -802,6 +627,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & call MOM_error(FATAL,"Stokes Mixing called without allocated"//& "Waves Control Structure") endif + lfpmix = .false. + if ( present(fpmix) ) lfpmix = fpmix do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo @@ -814,11 +641,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & do j=G%jsc,G%jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo + ! WGL: Brandon Reichl says the following is obsolete. u(I,j,k) already + ! includes Stokes. ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) enddo ; enddo ; endif + if ( lfpmix ) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) + enddo ; enddo ; endif + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif @@ -976,6 +809,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (do_i(I)) u(I,j,k) = u(I,j,k) - Waves%Us_x(I,j,k) enddo ; enddo ; endif + if ( lfpmix ) then ; do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) u(I,j,k) = u(I,j,k) + Waves%Us_x(I,j,k) + enddo ; enddo ; endif + enddo ! end u-component j loop ! Now work on the meridional velocity component. @@ -991,6 +828,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (do_i(i)) v(i,j,k) = v(i,j,k) + Waves%Us_y(i,j,k) enddo ; enddo ; endif + if ( lfpmix ) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,j,k) = v(i,j,k) - Waves%Us_y(i,j,k) + enddo ; enddo ; endif + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif @@ -1119,6 +960,10 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (do_i(i)) v(i,J,k) = v(i,J,k) - Waves%Us_y(i,J,k) enddo ; enddo ; endif + if ( lfpmix ) then ; do k=1,nz ; do i=is,ie + if (do_i(i)) v(i,J,k) = v(i,J,k) + Waves%Us_y(i,J,k) + enddo ; enddo ; endif + enddo ! end of v-component J loop ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. @@ -2618,7 +2463,7 @@ end subroutine vertvisc_limit_vel !> Initialize the vertical friction module subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & - ntrunc, CS) + ntrunc, CS, fpmix) type(ocean_internal_state), & target, intent(in) :: MIS !< The "MOM Internal State", a set of pointers !! to the fields and accelerations that make @@ -2633,6 +2478,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & type(directories), intent(in) :: dirs !< Relevant directory paths integer, target, intent(inout) :: ntrunc !< Number of velocity truncations type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + logical, optional, intent(in) :: fpmix !< Nonlocal momentum mixing ! Local variables @@ -2640,6 +2486,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-1] integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + logical :: lfpmix character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2664,6 +2511,9 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%diag => diag ; CS%ntrunc => ntrunc ; ntrunc = 0 + lfpmix = .false. + if (present(fpmix)) lfpmix = fpmix + ! Default, read and log parameters call log_version(param_file, mdl, version, "", log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & @@ -2966,20 +2816,29 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & thickness_units, conversion=US%Z_to_m) - CS%id_FPw2x = register_diag_field('ocean_model', 'FPw2x', diag%axesT1, Time, & - 'Wind direction from x-axis','radians') - CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & - 'Stress Mag Profile (u-points)', 'm2 s-2') - CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & - 'Stress Mag Profile (v-points)', 'm2 s-2') - CS%id_FPtau2s_u = register_diag_field('ocean_model', 'FPtau2s_u', diag%axesCui, Time, & - 'stress from shear direction (u-points)', 'radians ') - CS%id_FPtau2s_v = register_diag_field('ocean_model', 'FPtau2s_v', diag%axesCvi, Time, & - 'stress from shear direction (v-points)', 'radians') - CS%id_FPtau2w_u = register_diag_field('ocean_model', 'FPtau2w_u', diag%axesCui, Time, & - 'stress from wind direction (u-points)', 'radians') - CS%id_FPtau2w_v = register_diag_field('ocean_model', 'FPtau2w_v', diag%axesCvi, Time, & - 'stress from wind direction (v-points)', 'radians') + if (lfpmix) then + CS%id_uE_h = register_diag_field('ocean_model', 'uE_h' , CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vE_h = register_diag_field('ocean_model', 'vE_h' , CS%diag%axesTL, & + Time, 'y-merid Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_uInc_h = register_diag_field('ocean_model','uInc_h',CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vInc_h = register_diag_field('ocean_model','vInc_h',CS%diag%axesTL, & + Time, 'x-zonal Eulerian' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_uStk = register_diag_field('ocean_model', 'uStk' , CS%diag%axesTL, & + Time, 'x-FP du increment' , 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vStk = register_diag_field('ocean_model', 'vStk' , CS%diag%axesTL, & + Time, 'y-FP dv increment' , 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_FPtau2s = register_diag_field('ocean_model','Omega_tau2s',CS%diag%axesTi, & + Time, 'Stress direction from shear','radians') + CS%id_FPtau2w = register_diag_field('ocean_model','Omega_tau2w',CS%diag%axesTi, & + Time, 'Stress direction from wind','radians') + CS%id_uStk0 = register_diag_field('ocean_model', 'uStk0' , diag%axesT1, & + Time, 'Zonal Surface Stokes', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vStk0 = register_diag_field('ocean_model', 'vStk0' , diag%axesT1, & + Time, 'Merid Surface Stokes', 'm s-1', conversion=US%L_T_to_m_s) + endif CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 656ff5b569..3744469891 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -715,7 +715,7 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) enddo do j=G%jsc,G%jec do i=G%isc,G%iec - !CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) + CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) do b=1,CS%NumBands CS%UStk_Hb(i,j,b) = forces%UStkb(i,j,b) CS%VStk_Hb(i,j,b) = forces%VStkb(i,j,b) From 37411fb6d20387799aa7d24e53728cf025953481 Mon Sep 17 00:00:00 2001 From: Michael Levy Date: Mon, 9 Sep 2024 14:49:17 -0600 Subject: [PATCH 25/31] Check if fluxes%salt_flux is associated (#301) Do not want to compute net_salt_rate or any of the flux_from_salt_flux(:,:) terms if salt_flux is not being used in the fluxes derived type --- src/tracer/MARBL_tracers.F90 | 110 ++++++++++++++++++----------------- 1 file changed, 56 insertions(+), 54 deletions(-) diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index 0896917f2c..acb76e4e52 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -1392,67 +1392,69 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, enddo enddo - ! convert salt flux to tracer fluxes and add to STF - do j=js,je ; do i=is,ie - net_salt_rate(i,j) = (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j)) * GV%RZ_to_H - enddo ; enddo - - ! DIC related tracers - do j=js,je ; do i=is,ie - flux_from_salt_flux(i,j) = (CS%DIC_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) - enddo ; enddo - m = CS%tracer_inds%dic_ind - if (m > 0) then + if (associated(fluxes%salt_flux)) then + ! convert salt flux to tracer fluxes and add to STF do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + net_salt_rate(i,j) = (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j)) * GV%RZ_to_H enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) - endif - m = CS%tracer_inds%dic_alt_co2_ind - if (m > 0) then - do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) - enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) - endif - m = CS%tracer_inds%abio_dic_ind - if (m > 0) then - do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) - enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) - endif - m = CS%tracer_inds%abio_di14c_ind - if (m > 0) then - do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) - enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) - endif - ! ALK related tracers - do j=js,je ; do i=is,ie - flux_from_salt_flux(i,j) = (CS%ALK_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) - enddo ; enddo - m = CS%tracer_inds%alk_ind - if (m > 0) then + ! DIC related tracers do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + flux_from_salt_flux(i,j) = (CS%DIC_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) - endif - m = CS%tracer_inds%alk_alt_co2_ind - if (m > 0) then + m = CS%tracer_inds%dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%dic_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_dic_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%abio_di14c_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + + ! ALK related tracers do j=js,je ; do i=is,ie - CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + flux_from_salt_flux(i,j) = (CS%ALK_salt_ratio * GV%H_to_Z) * net_salt_rate(i,j) enddo ; enddo - if (CS%id_surface_flux_from_salt_flux(m) > 0) & - call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + m = CS%tracer_inds%alk_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif + m = CS%tracer_inds%alk_alt_co2_ind + if (m > 0) then + do j=js,je ; do i=is,ie + CS%STF(i,j,m) = CS%STF(i,j,m) + flux_from_salt_flux(i,j) + enddo ; enddo + if (CS%id_surface_flux_from_salt_flux(m) > 0) & + call post_data(CS%id_surface_flux_from_salt_flux(m), flux_from_salt_flux, CS%diag) + endif endif if (CS%debug) then From a3e2f1485cf3a2e91c82c9d4c7934f12574deebb Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Mon, 23 Sep 2024 18:58:27 -0600 Subject: [PATCH 26/31] fix memory leak in NUOPC State_getImport method (#303) --- .../drivers/nuopc_cap/mom_cap_methods.F90 | 30 ++----------------- 1 file changed, 2 insertions(+), 28 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index bb12dc6092..180202c7e6 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -42,7 +42,6 @@ module MOM_cap_methods !> Get field pointer interface State_GetFldPtr module procedure State_GetFldPtr_1d - module procedure State_GetFldPtr_1d_from_2d module procedure State_GetFldPtr_2d end interface @@ -850,32 +849,6 @@ subroutine State_GetFldPtr_1d(State, fldname, fldptr, rc) end subroutine State_GetFldPtr_1d -!> Get specific 1D field pointer from 2D field -subroutine State_GetFldPtr_1d_from_2d(State, fldname, esmf_ind, fldptr, rc) - type(ESMF_State) , intent(in) :: State !< ESMF state - character(len=*) , intent(in) :: fldname !< Field name - real(ESMF_KIND_R8), pointer :: fldptr(:)!< Pointer to the 1D field - integer, intent(in) :: esmf_ind !< Index into 2D ESMF array - integer, optional , intent(out) :: rc !< Return code - - ! local variables - real(ESMF_KIND_R8), pointer :: fldptr2d(:,:)!< Pointer to the 1D field - type(ESMF_Field) :: lfield - integer :: lrc - character(len=*),parameter :: subname='(MOM_cap:State_GetFldPtr)' - - call ESMF_StateGet(State, itemName=trim(fldname), field=lfield, rc=lrc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayPtr=fldptr2d, rc=lrc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (.not. associated(fldptr)) allocate(fldptr(size(fldptr2d,2))) - fldptr = fldptr2d(esmf_ind, :) - - if (present(rc)) rc = lrc - -end subroutine State_GetFldPtr_1d_from_2d - !> Get field pointer 2D subroutine State_GetFldPtr_2d(State, fldname, fldptr, rc) type(ESMF_State) , intent(in) :: State !< ESMF state @@ -940,7 +913,8 @@ subroutine State_GetImport_2d(state, fldname, isc, iec, jsc, jec, output, do_sum ! get field pointer if (present(esmf_ind)) then - call state_getfldptr(state, trim(fldname), esmf_ind, dataptr1d, rc) + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + dataptr1d => dataptr2d(esmf_ind,:) else call state_getfldptr(state, trim(fldname), dataptr1d, rc) endif From 5726d941dc709c1feadfc9b60a9dac7781b49d30 Mon Sep 17 00:00:00 2001 From: Michael Levy Date: Fri, 27 Sep 2024 15:25:57 -0600 Subject: [PATCH 27/31] Don't compute log10(chl) for small chl if chl <= chl_min, we already have log10(chl_min) stored as a parameter. Avoiding the computation of log10(chl) in those cases prevents the possibility of a floating point exception, and lets us replace a max() statement with an if check so it shouldn't affect performance. This requires adding chl_min to the optics_type (which already has log10chl_min and log10chl_max). --- src/parameterizations/vertical/MOM_opacity.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 831607d2db..9d2339a440 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -45,6 +45,7 @@ module MOM_opacity !! Lookup tables for Ohlmann solar penetration scheme !! These would naturally exist as private module variables but that is prohibited in MOM6 real :: dlog10chl !< Chl increment within lookup table + real :: chl_min !< Lower bound of Chl in lookup table real :: log10chl_min !< Lower bound of Chl in lookup table real :: log10chl_max !< Upper bound of Chl in lookup table real, allocatable, dimension(:) :: a1_lut,& !< Coefficient for band 1 @@ -1303,6 +1304,7 @@ subroutine init_ohlmann_table(optics) call MOM_error(FATAL,"init_ohlmann: Cannot allocate lookup table") endif + optics%chl_min = chl_tab1a(1) optics%log10chl_min = log10(chl_tab1a(1)) optics%log10chl_max = log10(chl_tab1a(nval_tab1a)) optics%dlog10chl = (optics%log10chl_max - optics%log10chl_min)/(nval_lut-1) @@ -1349,7 +1351,11 @@ function lookup_ohlmann_swpen(chl,optics) result(A) integer :: n ! Make sure we are in the table - log10chl = max(optics%log10chl_min,min(log10(chl),optics%log10chl_max)) + if (chl > optics%chl_min) then + log10chl = min(log10(chl),optics%log10chl_max) + else + log10chl = optics%log10chl_min + endif ! Do a nearest neighbor lookup n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 From 00beb269fcb4b9e2ac7b9ff2c9143bb981918dc6 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Sat, 28 Sep 2024 18:17:38 -0600 Subject: [PATCH 28/31] add timestamp to rpointer files (#304) * add timestamp to rpointer files * fix restart file names --- config_src/drivers/nuopc_cap/mom_cap.F90 | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 5f4b2e19ca..6468de5a19 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -449,9 +449,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar + character(len=17) :: timestamp character(len=:), allocatable :: rpointer_filename integer :: inst_index logical :: i2o_per_cat + logical :: found=.false. ! rpointer inquiry real(8) :: MPI_Wtime, timeiads !-------------------------------- @@ -487,7 +489,14 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call get_component_instance(gcomp, inst_suffix, inst_index, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ensemble_manager_init(inst_suffix) - rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + + write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)'),year,month,day,hour*3600+minute*60+second + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix)//timestamp + inquire(file=trim(rpointer_filename), exist=found) + ! for backward compatibility + if (.not. found) then + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + endif #endif ! reset shr logging to my log file @@ -1682,7 +1691,6 @@ subroutine ModelAdvance(gcomp, rc) integer(ESMF_KIND_I8) :: n_interval, time_elapsed_sec type(ESMF_Field) :: lfield type(ESMF_StateItem_Flag) :: itemType - character(len=64) :: timestamp type (ocean_public_type), pointer :: ocean_public => NULL() type (ocean_state_type), pointer :: ocean_state => NULL() type(ice_ocean_boundary_type), pointer :: Ice_ocean_boundary => NULL() @@ -1708,6 +1716,7 @@ subroutine ModelAdvance(gcomp, rc) character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' character(len=8) :: suffix character(len=:), allocatable :: rpointer_filename + character(len=17) :: timestamp integer :: num_rest_files real(8) :: MPI_Wtime, timers logical :: write_restart @@ -1909,10 +1918,12 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_VMGet(vm, localPet=localPet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + write(timestamp,'(".",i4.4,"-",i2.2,"-",i2.2,"-",i5.5)'),year,month,day,hour*3600+minute*60+seconds + + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix)//timestamp - write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & - trim(casename), year, month, day, hour * 3600 + minute * 60 + seconds + write(restartname,'(A,".mom6.r",A)') & + trim(casename), timestamp call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) @@ -2234,7 +2245,6 @@ subroutine ocean_model_finalize(gcomp, rc) type(ESMF_Time) :: currTime type(ESMF_Alarm), allocatable :: alarmList(:) integer :: alarmCount - character(len=64) :: timestamp logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' real(8) :: MPI_Wtime, timefs From 8fb8aaf83b9afb8e10ea87f1084d0066f2707b47 Mon Sep 17 00:00:00 2001 From: Michael Levy Date: Tue, 1 Oct 2024 13:53:13 -0600 Subject: [PATCH 29/31] Avoid chl=0 in lookup_ohlmann_opacity() previous commit only avoiding log10(0) in lookup_ohlmann_swpen() but we have another log10(chl) in the opacity function --- src/parameterizations/vertical/MOM_opacity.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 9d2339a440..b8b8c56d21 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1377,7 +1377,11 @@ function lookup_ohlmann_opacity(chl,optics) result(B) integer :: n ! Make sure we are in the table - log10chl = max(optics%log10chl_min,min(log10(chl),optics%log10chl_max)) + if (chl > optics%chl_min) then + log10chl = min(log10(chl),optics%log10chl_max) + else + log10chl = optics%log10chl_min + endif ! Do a nearest neighbor lookup n = nint( (log10chl - optics%log10chl_min)/optics%dlog10chl ) + 1 From 843d3b69755c4f688c5fa39c6500b4e1a55158a7 Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Thu, 10 Oct 2024 14:26:14 -0600 Subject: [PATCH 30/31] Fix units and dimensional consistency --- src/ALE/MOM_ALE.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 3a4934676d..4bbc3d4420 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -380,12 +380,12 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'Rate of change in half rho0 times depth integral of squared zonal'//& ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& ' this measures the change before the KE-conserving correction is applied.', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2 * US%L_to_Z**2) + 'W m-2', conversion=GV%H_to_kg_m2 * US%L_T_to_m_s**2 * US%s_to_T) CS%id_remap_delta_integ_v2 = register_diag_field('ocean_model', 'ale_v2', diag%axesCv1, Time, & 'Rate of change in half rho0 times depth integral of squared meridional'//& ' velocity by remapping. If REMAP_VEL_CONSERVE_KE is .true. then '//& ' this measures the change before the KE-conserving correction is applied.', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2 * US%L_to_Z**2) + 'W m-2', conversion=GV%H_to_kg_m2 * US%L_T_to_m_s**2 * US%s_to_T) end subroutine ALE_register_diags @@ -1172,7 +1172,11 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u ke_c_tgt = ke_c_tgt + h2(k) * (u_tgt(k) - u_bt)**2 enddo ! Next rescale baroclinic component on target grid to conserve ke - rescale_coef = min(1.25, sqrt(ke_c_src / (ke_c_tgt + 1.E-19))) + if (ke_c_src < 1.5625 * ke_c_tgt) then + rescale_coef = sqrt(ke_c_src / ke_c_tgt) + else + rescale_coef = 1.25 + endif do k=1,nz u_tgt(k) = u_bt + rescale_coef * (u_tgt(k) - u_bt) enddo @@ -1240,7 +1244,11 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u ke_c_tgt = ke_c_tgt + h2(k) * (v_tgt(k) - v_bt)**2 enddo ! Next rescale baroclinic component on target grid to conserve ke - rescale_coef = min(1.25, sqrt(ke_c_src / (ke_c_tgt + 1.E-19))) + if (ke_c_src < 1.5625 * ke_c_tgt) then + rescale_coef = sqrt(ke_c_src / ke_c_tgt) + else + rescale_coef = 1.25 + endif do k=1,nz v_tgt(k) = v_bt + rescale_coef * (v_tgt(k) - v_bt) enddo From 5331dadae8094ff2a7386730467ea8359e32cdf5 Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Wed, 16 Oct 2024 17:31:22 -0600 Subject: [PATCH 31/31] Remove offending dimensional factor --- src/ALE/MOM_ALE.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4bbc3d4420..d1aeffddea 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1186,7 +1186,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u do k=1,nz u2h_tot = u2h_tot + h2(k) * (u_tgt(k)**2) enddo - du2h_tot(I,j) = GV%H_to_RZ * u2h_tot * I_dt + du2h_tot(I,j) = u2h_tot * I_dt endif if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & @@ -1258,7 +1258,7 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u do k=1,nz v2h_tot = v2h_tot + h2(k) * (v_tgt(k)**2) enddo - dv2h_tot(I,j) = GV%H_to_RZ * v2h_tot * I_dt + dv2h_tot(I,j) = v2h_tot * I_dt endif if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then