diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index a22fb3534b..a70232cba6 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -8,6 +8,7 @@ module MOM_cap_mod use MOM_domains, only: get_domain_extent use MOM_io, only: stdout, io_infra_end +use MOM_io, only: insert_ensemble_appendix use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes @@ -28,6 +29,7 @@ module MOM_cap_mod use MOM_ocean_model_nuopc, only: ocean_model_init_sfc, ocean_model_flux_init use MOM_ocean_model_nuopc, only: ocean_model_init, update_ocean_model, ocean_model_end use MOM_ocean_model_nuopc, only: get_ocean_grid, get_eps_omesh, query_ocean_state +use MOM_ocean_model_nuopc, only: stoch_restart_needed use MOM_cap_time, only: AlarmInit use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose @@ -1775,7 +1777,7 @@ subroutine ModelAdvance(gcomp, rc) character(240) :: msgString character(ESMF_MAXSTR) :: casename integer :: iostat - integer :: writeunit + integer :: rpointer_unit type(ESMF_VM) :: vm integer :: n, i character(240) :: import_timestr, export_timestr @@ -1994,25 +1996,27 @@ subroutine ModelAdvance(gcomp, rc) rpointer_filename = trim(rpointer_filename//timestamp) endif - write(restartname,'(A,".mom6.r",A)') & - trim(casename), timestamp + write(restartname,'(A,".mom6.r",A)') trim(casename), timestamp + write(stoch_restartname,'(A,".mom6.r_stoch",A,".nc")') trim(casename), timestamp + + call insert_ensemble_appendix(stoch_restartname, ".mom6") + 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) + call ocean_model_restart(ocean_state, restartname=restartname, & + stoch_restartname=stoch_restartname, num_rest_files=num_rest_files) if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean - open(newunit=writeunit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) + open(newunit=rpointer_unit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & msg=subname//' ERROR opening '//rpointer_filename, line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - if (len_trim(inst_suffix) == 0) then - write(writeunit,'(a)') trim(restartname)//'.nc' - else - write(writeunit,'(a)') trim(restartname)//'.'//trim(inst_suffix)//'.nc' - endif + call insert_ensemble_appendix(restartname, ".mom6") + + write(rpointer_unit,'(a)') trim(restartname)//'.nc' if (num_rest_files > 1) then ! append i.th restart file name to rpointer do i=1, num_rest_files-1 @@ -2021,10 +2025,15 @@ subroutine ModelAdvance(gcomp, rc) else write(suffix,'("_",I2)') i endif - write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + write(rpointer_unit,'(a)') trim(restartname) // trim(suffix) // '.nc' enddo endif - close(writeunit) + + if (stoch_restart_needed(ocean_state)) then + write(rpointer_unit,'(a)') trim(stoch_restartname) + endif + + close(rpointer_unit) endif else ! not cesm_coupled write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & @@ -2091,6 +2100,7 @@ subroutine ModelSetRunClock(gcomp, rc) type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime type(ESMF_Time) :: mstoptime, dstoptime + type(ESMF_Time) :: mstoptime_prev ! model stop time before it is updated by this routine type(ESMF_TimeInterval) :: mtimestep, dtimestep character(len=128) :: mtimestring, dtimestring character(len=256) :: cvalue @@ -2118,7 +2128,8 @@ subroutine ModelSetRunClock(gcomp, rc) stopTime=dstoptime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) + call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, & + stopTime=mstoptime_prev, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !-------------------------------- @@ -2242,12 +2253,21 @@ subroutine ModelSetRunClock(gcomp, rc) endif ! create a 1-shot alarm at the driver stop time - stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) - call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cesm_coupled) then + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=mstoptime_prev, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) - call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + call ESMF_TimeGet(mstoptime_prev, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + else + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + endif call outputlog_init(gcomp, mclock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return 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 96a49348cc..734e865291 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -64,6 +64,7 @@ module MOM_ocean_model_nuopc use MOM_surface_forcing_nuopc, only : ice_ocean_boundary_type, surface_forcing_CS use MOM_surface_forcing_nuopc, only : forcing_save_restart use get_stochy_pattern_mod, only : write_stoch_restart_ocn +use stochy_data_mod, only : stoch_restfile use iso_fortran_env, only : int64 #include @@ -83,6 +84,7 @@ module MOM_ocean_model_nuopc public ocean_public_type_chksum public get_ocean_grid, query_ocean_state public get_eps_omesh +public stoch_restart_needed !> This type is used for communication with other components via the FMS coupler. !! The element names and types can be changed only with great deliberation, hence @@ -180,11 +182,12 @@ module MOM_ocean_model_nuopc !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic !! processes before time stepping the dynamics. - logical :: do_sppt !< If true, stochastically perturb the diabatic and - !! write restarts - logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and - !! genration termsand write restarts - + logical :: do_sppt !< If true, stochastically perturb the diabatic + !! tendencies and write restarts + logical :: pert_epbl !< If true, then randomly perturb the KE dissipation and + !! generation terms and write restarts + logical :: do_skeb !< If true, stochastically perturb the ocean lateral + !! velocity and write restarts real :: eps_omesh !< Max allowable difference between ESMF mesh and MOM6 !! domain coordinates @@ -268,6 +271,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i integer :: secs, days type(param_file_type) :: param_file !< A structure to parse for run-time parameters logical :: use_temperature + integer :: i, k call callTree_enter("ocean_model_init(), ocean_model_MOM.F90") if (associated(OS)) then @@ -283,6 +287,19 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call time_interp_external_init OS%Time = Time_in + if(present(input_restart_file)) then + k = index(input_restart_file, ' ') + if (k==0) k = len_trim(input_restart_file) + i = index(input_restart_file, '.r.') + if (i>0) then + stoch_restfile = input_restart_file(1:i)//'r_stoch'//input_restart_file(i+2:k) + + if (is_root_pe()) then + write(stdout,*) 'input_restart_file =', input_restart_file + write(stdout,*) 'stoch_restfile =', stoch_restfile + endif + endif + endif call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & @@ -389,7 +406,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! 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_marbl_tracers=OS%use_MARBL) + use_meltpot=use_melt_pot, use_MARBL_tracers=OS%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) @@ -446,6 +463,10 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "production and dissipation terms. 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", OS%do_skeb, & + "If true, then stochastically perturb the currents "//& + "using the stochastic kinetic energy backscatter scheme.",& + default=.false.) call close_param_file(param_file) call diag_mediator_close_registration(OS%diag) @@ -545,9 +566,6 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & 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, & @@ -772,8 +790,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu endif endif if (present(stoch_restartname)) then - if (OS%do_sppt .OR. OS%pert_epbl) then - call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) + if (stoch_restart_needed(OS)) then + call write_stoch_restart_ocn(trim(stoch_restartname)) endif endif @@ -1130,7 +1148,6 @@ end subroutine Ocean_stock_pe !> Write out checksums for fields from the ocean surface state subroutine ocean_public_type_chksum(id, timestep, ocn) - character(len=*), intent(in) :: id !< An identifying string for this call integer, intent(in) :: timestep !< The number of elapsed timesteps type(ocean_public_type), intent(in) :: ocn !< A structure containing various publicly @@ -1156,8 +1173,8 @@ end subroutine ocean_public_type_chksum subroutine get_ocean_grid(OS, Gridp) ! Obtain the ocean grid. - type(ocean_state_type) :: OS - type(ocean_grid_type) , pointer :: Gridp + type(ocean_state_type), intent(in) :: OS + type(ocean_grid_type) , pointer, intent(out) :: Gridp Gridp => OS%grid return @@ -1165,8 +1182,14 @@ end subroutine get_ocean_grid !> Returns eps_omesh read from param file real function get_eps_omesh(OS) - type(ocean_state_type) :: OS + type(ocean_state_type), intent(in) :: OS get_eps_omesh = OS%eps_omesh; return end function +!> Returns true if a stochastic restart file is needed +logical function stoch_restart_needed(OS) + type(ocean_state_type), intent(in) :: OS + stoch_restart_needed = OS%do_sppt .OR. OS%pert_epbl .OR. OS%do_skeb +end function stoch_restart_needed + end module MOM_ocean_model_nuopc 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 b82cb00f01..5d3bdc2462 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -83,7 +83,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 :: 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] @@ -328,7 +328,7 @@ 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=.not.CS%ustar_gustless_bug, & - cfc=CS%use_CFC, marbl=CS%use_marbl_tracers, hevap=CS%enthalpy_cpl, & + 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%sw_vis_dir,isd,ied,jsd,jed) @@ -617,7 +617,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Copy MARBL-specific IOB fields into fluxes; also set some MARBL-specific forcings to other values ! (constants, values from netCDF, etc) - if (CS%use_marbl_tracers) & + if (CS%use_MARBL_tracers) & 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, & @@ -1274,7 +1274,7 @@ 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, & + 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, & @@ -1470,7 +1470,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, 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_glc_runoff=glc_runoff_diags) + use_cfcs=CS%use_CFC, use_MARBL_tracers=CS%use_MARBL_tracers, & + 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 "//& @@ -1485,7 +1486,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, endif ! Set up MARBL forcing control structure - call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + 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 diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 50f70c3978..660f4d84e6 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -118,7 +118,7 @@ module MOM_surface_forcing !! rotationally invariant and more likely to be the same between compilers. logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. - logical :: use_marbl_tracers !< If true, allocate memory for forcing needed by MARBL + logical :: use_MARBL_tracers !< If true, allocate memory for forcing needed by MARBL ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-2 ~> Pa] @@ -289,7 +289,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, marbl=CS%use_marbl_tracers, 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=.not.CS%ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then @@ -386,7 +386,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif endif - if (CS%use_marbl_tracers) then + if (CS%use_MARBL_tracers) then call MARBL_forcing_from_data_override(fluxes, day_center, G, US, CS) endif @@ -2150,7 +2150,7 @@ 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*US%L_to_Z) ! units in file should be [Pa] endif - call get_param(param_file, mdl, "USE_MARBL_TRACERS", CS%use_marbl_tracers, & + 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. @@ -2183,7 +2183,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C endif ! Set up MARBL forcing control structure - call MARBL_forcing_init(G, US, param_file, diag, Time, CS%inputdir, CS%use_marbl_tracers, & + 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) diff --git a/config_src/external/MARBL/marbl_interface.F90 b/config_src/external/MARBL/marbl_interface.F90 index 4b57472798..e4f4f51cfb 100644 --- a/config_src/external/MARBL/marbl_interface.F90 +++ b/config_src/external/MARBL/marbl_interface.F90 @@ -41,6 +41,7 @@ module marbl_interface procedure, public :: put_setting !< dummy put_setting routine procedure, public :: get_setting !< dummy get_setting routine procedure, public :: init !< dummy init routine + procedure, public :: autotroph_tracer_consistency_enforce !< dummy consistency enforcement procedure, public :: compute_totChl !< dummy routine to compute total Chlorophyll procedure, public :: surface_flux_compute !< dummy surface flux routine procedure, public :: interior_tendency_compute !< dummy interior tendency routine @@ -95,6 +96,15 @@ subroutine init(self, & call MOM_error(FATAL, error_msg) end subroutine init + !> Dummy version of MARBL's autotroph_tracer_consistency_enforce() function + subroutine autotroph_tracer_consistency_enforce(self) + + class(marbl_interface_class), intent(inout) :: self + + call MOM_error(FATAL, error_msg) + + end subroutine autotroph_tracer_consistency_enforce + !> Dummy version of MARBL's compute_totChl() function subroutine compute_totChl(self) diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 index 40f9cf9fa8..718e80ab8a 100644 --- a/config_src/external/stochastic_physics/stochastic_physics.F90 +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -60,7 +60,7 @@ end subroutine init_stochastic_physics_ocn !> Determines the stochastic physics perturbations. 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) :: skeb_wts(:,:) !< array containing random weights for SKEB with units of a length [m] 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/config_src/external/stochastic_physics/stochy_data_mod.F90 b/config_src/external/stochastic_physics/stochy_data_mod.F90 new file mode 100644 index 0000000000..f67513a956 --- /dev/null +++ b/config_src/external/stochastic_physics/stochy_data_mod.F90 @@ -0,0 +1,10 @@ +!>@brief The module 'stochy_data_mod' contains the initilization routine that read the stochastic phyiscs +!! namelist and determins the number of random patterns. +module stochy_data_mod + +implicit none +public :: stoch_restfile + +character(len=128) :: stoch_restfile = './INPUT/ocn_stoch.res.nc' !< default restart file name + +end module stochy_data_mod diff --git a/docs/zotero.bib b/docs/zotero.bib index 01fe2c6185..eb2423de02 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -1,5 +1,34 @@ % This file is generated by zotero. Manual edits will be lost! +@article{agarwal2023, + title={Impact of Stochastic Ocean Density Corrections on Air-Sea Flux Variability}, + author={Agarwal, Niraj and Small, R Justin and Bryan, Frank O and Grooms, Ian and Pegion, Philip J}, + journal={Geophysical Research Letters}, + volume={50}, + number={13}, + pages={e2023GL104248}, + year={2023}, +} + +@article{kenigson2022, + title={Parameterizing the impact of unresolved temperature variability on the large-scale density field: 2. Modeling}, + author={Kenigson, JS and Adcroft, A and Bachman, SD and Castruccio, F and Grooms, I and Pegion, P and Stanley, Z}, + journal={Journal of Advances in Modeling Earth Systems}, + volume={14}, + number={3}, + pages={e2021MS002844}, + year={2022}, +} + +@article{stanley2020, + title={Parameterizing the Impact of Unresolved Temperature Variability on the Large-Scale Density Field: {Part 1.} Theory.}, + author={Stanley, Z and Grooms, I and Kleiber, W and Bachman, SD and Castruccio, F and Adcroft, A}, + journal={Journal of Advances in Modeling Earth Systems}, + volume={12}, + number={12}, + pages={e2020MS002185}, + year={2020}, +} @article{redi1982, title = {Oceanic {Isopycnal} {Mixing} by {Coordinate} {Rotation}}, diff --git a/pkg/CVMix-src b/pkg/CVMix-src index c38ddb7ebd..9187de96a4 160000 --- a/pkg/CVMix-src +++ b/pkg/CVMix-src @@ -1 +1 @@ -Subproject commit c38ddb7ebdd2d58c517b63a99bbdc8e348732db2 +Subproject commit 9187de96a40ca55ec7b43524a2bf0ace10bcae67 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 4b55700217..0f48fc9d7c 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -36,6 +36,7 @@ module MOM use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_version, param_file_type +use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : Get_MOM_Input, directories @@ -146,6 +147,7 @@ module MOM use MOM_tracer_registry, only : tracer_registry_type, register_tracer, tracer_registry_init use MOM_tracer_registry, only : register_tracer_diagnostics, post_tracer_diagnostics_at_sync use MOM_tracer_registry, only : post_tracer_transport_diagnostics, MOM_tracer_chksum +use MOM_tracer_registry, only : post_tracer_integral_diagnostics use MOM_tracer_registry, only : preALE_tracer_diagnostics, postALE_tracer_diagnostics use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS @@ -320,6 +322,10 @@ module MOM logical :: useMEKE !< If true, call the MEKE parameterization. logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. logical :: useWaves !< If true, update Stokes drift + logical :: StokesMOST !< If true, use Stokes Similarity package. Needed to decide if Lam2 should + !! be passed to mixedlayer_restrat. + logical :: wave_enhanced_ustar !< If true, enhance ustar in Bodner23. Needed to decide if Lam2 should + !! be passed to mixedlayer_restrat. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the !! barotropic time step [T ~> s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. @@ -395,6 +401,15 @@ module MOM type(diag_grid_storage) :: diag_pre_sync !< The grid (thicknesses) before remapping type(diag_grid_storage) :: diag_pre_dyn !< The grid (thicknesses) before dynamics + logical :: accumulate_resolved_flux = .false. !< If true, accumulate resolved flux for tracers for diagnostics + !! separating the tracer flux due to resolved and parameterized flow + logical :: do_resolved_advection = .false. !< If true, calculate advection by resolved flow + logical :: do_param_advection = .false. !< If true, calculate advection by parameterized flow + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + uhtr_resolved !< accumulated zonal thickness fluxes due to resolved flow to advect tracers [H L2 ~> m3 or kg] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + vhtr_resolved !< accumulated meridional thickness fluxes due to resolved flow to advect tracers [H L2 ~> m3 or kg] + ! The remainder of this type provides pointers to child module control structures. type(MOM_dyn_unsplit_CS), pointer :: dyn_unsplit_CSp => NULL() @@ -1048,6 +1063,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS CS%CDp, p_surf, CS%t_dyn_rel_diag, CS%diag_pre_sync,& G, GV, US, CS%diagnostics_CSp) call post_tracer_diagnostics_at_sync(CS%Tracer_reg, h, CS%diag_pre_sync, CS%diag, G, GV, CS%t_dyn_rel_diag) + call post_tracer_integral_diagnostics(G, GV, US, CS%Tracer_reg, h, CS%tv, CS%diag) + call diag_copy_diag_to_storage(CS%diag_pre_sync, h, CS%diag) if (showCallTree) call callTree_waypoint("finished calculate_diagnostic_fields (step_MOM)") call disable_averaging(CS%diag) @@ -1329,6 +1346,19 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & endif ! -------------------------------------------------- end SPLIT + ! Accumulate resolved flux for tracer diagnostics + if (CS%accumulate_resolved_flux) then + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + CS%uhtr_resolved(I,j,k) = CS%uhtr_resolved(I,j,k) + CS%uh(I,j,k)*dt + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + CS%vhtr_resolved(i,J,k) = CS%vhtr_resolved(i,J,k) + CS%vh(i,J,k)*dt + enddo ; enddo + enddo + endif + if (CS%use_particles .and. CS%do_dynamics .and. (.not. CS%use_uh_particles)) then if (CS%thickness_diffuse_first) call MOM_error(WARNING,"particles_run: "//& "Thickness_diffuse_first is true and use_uh_particles is false. "//& @@ -1407,8 +1437,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_tr_adv, & CS%uhtr, CS%vhtr, G%HI, haloshift=0, unscale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) - call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & - CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) + if (CS%wave_enhanced_ustar .and. CS%StokesMOST) then + if (associated(CS%visc%Lam2)) then + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & + CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp, CS%visc%Lam2) + else + call MOM_error(FATAL,'step_MOM_dynamics:CS%visc%Lam2 not associated') + endif + else + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & + CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) + endif call cpu_clock_end(id_clock_ml_restrat) call pass_var(h, G%Domain, clock=id_clock_pass, halo=CS%dyn_h_stencil) if (CS%debug) then @@ -1478,9 +1517,19 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) type(group_pass_type) :: pass_T_S integer :: halo_sz ! The size of a halo where data must be valid. logical :: x_first ! If true, advect tracers first in the x-direction, then y. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + uhtr_tmp ! Temp. variable for advecting with alternate volume fluxes [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + vhtr_tmp ! Temp. variable for advecting with alternate volume fluxes[H L2 ~> m3 or kg] + integer :: i, j, k, m, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: IsdB, IedB, JsdB, JedB logical :: showCallTree + showCallTree = callTree_showQuery() + 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 + if (CS%debug) then call cpu_clock_begin(id_clock_other) call hchksum(h,"Pre-advection h", G%HI, haloshift=1, unscale=GV%H_to_MKS) @@ -1509,7 +1558,27 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) endif if (CS%debug) call MOM_tracer_chksum("Pre-advect ", CS%tracer_Reg, G) call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & - CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first) + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first, flux_type=0) + + if (CS%do_resolved_advection) then + call advect_tracer(h, CS%uhtr_resolved, CS%vhtr_resolved, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first, flux_type=1) + endif + + if (CS%do_param_advection) then + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr_tmp(I,j,k) = CS%uhtr(I,j,k) - CS%uhtr_resolved(I,j,k) + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr_tmp(i,J,k) = CS%vhtr(i,J,k) - CS%vhtr_resolved(i,J,k) + enddo ; enddo + enddo + call advect_tracer(h, uhtr_tmp, vhtr_tmp, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & + CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first, flux_type=2) + endif + if (CS%debug) call MOM_tracer_chksum("Post-advect ", CS%tracer_Reg, G) call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) @@ -1537,6 +1606,10 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call cpu_clock_begin(id_clock_thermo) ; call cpu_clock_begin(id_clock_tracer) CS%uhtr(:,:,:) = 0.0 CS%vhtr(:,:,:) = 0.0 + if (CS%accumulate_resolved_flux) then + CS%uhtr_resolved(:,:,:) = 0.0 + CS%vhtr_resolved(:,:,:) = 0.0 + endif CS%n_dyn_steps_in_adv = 0 CS%t_dyn_rel_adv = 0.0 call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) @@ -1670,7 +1743,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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) + call apply_skeb(G, GV, US, CS%stoch_CS, u, v, h, tv, dtdia, Time_end_thermo) endif if (showCallTree) call callTree_waypoint("finished diabatic (step_MOM_thermo)") @@ -2252,7 +2325,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! This include declares and sets the variable "version". # include "version_variable.h" - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB real :: dtbt ! If negative, this specifies the barotropic timestep as a fraction ! of the maximum stable value [nondim]. @@ -2395,12 +2468,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & 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 openParameterBlock(param_file, 'KPP', do_not_log=.true.) + call get_param(param_file, '', 'STOKES_MOST', CS%StokesMOST, & + 'If True, use Stokes Similarity package.', & + default=.False., do_not_log=.true.) + call closeParameterBlock(param_file) + call openParameterBlock(param_file,'MLE', do_not_log=.true.) + call get_param(param_file, '', "WAVE_ENHANCED_USTAR", CS%wave_enhanced_ustar, & + "If true, enhance ustar in Bodner23.", default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) 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, & @@ -3629,6 +3709,25 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif + ! determine if we need to accumulate resolved transports for tracer advection diagnostics + do m = 1,CS%tracer_Reg%ntr + if (CS%tracer_Reg%Tr(m)%id_adx_resolved > 0 .or. & + CS%tracer_Reg%Tr(m)%id_ady_resolved > 0) then + CS%accumulate_resolved_flux = .true. + CS%do_resolved_advection = .true. + endif + if (CS%tracer_Reg%Tr(m)%id_adx_param > 0 .or. & + CS%tracer_Reg%Tr(m)%id_ady_param > 0) then + CS%accumulate_resolved_flux = .true. + CS%do_param_advection = .true. + endif + enddo + if (CS%accumulate_resolved_flux) then + ALLOC_(CS%uhtr_resolved(IsdB:IedB,jsd:jed,nz)) ; CS%uhtr_resolved(:,:,:) = 0.0 + ALLOC_(CS%vhtr_resolved(isd:ied,JsdB:JedB,nz)) ; CS%vhtr_resolved(:,:,:) = 0.0 + endif + + ! Do any necessary halo updates on any auxiliary variables that have been initialized. call cpu_clock_begin(id_clock_pass_init) if (associated(CS%visc%Kv_shear)) & @@ -3709,7 +3808,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif ! initialize stochastic physics - call stochastics_init(CS%dt_therm, CS%G, CS%GV, CS%stoch_CS, param_file, diag, Time) + call stochastics_init(CS%dt_therm, CS%G, CS%GV, US, CS%stoch_CS, param_file, diag, Time) call callTree_leave("initialize_MOM()") call cpu_clock_end(id_clock_init) @@ -4522,6 +4621,10 @@ subroutine MOM_end(CS) DEALLOC_(CS%uhtr) ; DEALLOC_(CS%vhtr) + if (CS%accumulate_resolved_flux) then + DEALLOC_(CS%uhtr_resolved) ; DEALLOC_(CS%vhtr_resolved) + endif + if (associated(CS%Hml)) deallocate(CS%Hml) if (associated(CS%tv%salt_deficit)) deallocate(CS%tv%salt_deficit) if (associated(CS%tv%frazil)) deallocate(CS%tv%frazil) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index c118d17f21..b0e1934229 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -2032,8 +2032,6 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables - real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale - ! temperature variance [nondim] integer :: default_answer_date ! Global answer date logical :: use_temperature ! If true, temperature and salinity are used as state variables. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. @@ -2047,6 +2045,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL # include "version_variable.h" character(len=40) :: mdl ! This module's name. logical :: use_ALE ! If true, use the Vertical Lagrangian Remap algorithm + logical :: stoch_eos ! Can't use Stanley param here unless stoch_eos is true integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -2191,16 +2190,15 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, ADp, SAL "boundary cells is extrapolated, rather than using PCM "//& "in these cells. If true, the same order polynomial is "//& "used as is used for the interior cells.", default=.true.) + call get_param(param_file, mdl, "STOCH_EOS", stoch_eos, & + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "USE_STANLEY_PGF", CS%use_stanley_pgf, & "If true, turn on Stanley SGS T variance parameterization "// & "in PGF code.", default=.false.) if (CS%use_stanley_pgf) then - call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & - "Coefficient correlating the temperature gradient and SGS T variance.", & - units="nondim", default=-1.0, do_not_log=.true.) - if (Stanley_coeff < 0.0) call MOM_error(FATAL, & - "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") - + if (.not.stoch_eos) then + call MOM_error(FATAL, "PressureForce_FV_init: USE_STANLEY_PGF requires STOCH_EOS") + endif CS%id_rho_pgf = register_diag_field('ocean_model', 'rho_pgf', diag%axesTL, & Time, 'rho in PGF', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rho_stanley_pgf = register_diag_field('ocean_model', 'rho_stanley_pgf', diag%axesTL, & diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 8ebf5f7180..3c5b2c8bec 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -236,7 +236,12 @@ module MOM_forcing_type 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] + iron_flux => NULL(), & !< Flux of dust into the ocean [conc Z T-1 ~> conc m s-1] + atm_fine_dust_flux => NULL(), & !< Fine dust flux from atmosphere [R Z T-1 ~> kg m-2 s-1] + atm_coarse_dust_flux => NULL(), & !< Coarse dust flux from atmosphere [R Z T-1 ~> kg m-2 s-1] + seaice_dust_flux => NULL(), & !< Dust flux from seaice [R Z T-1 ~> kg m-2 s-1] + atm_bc_flux => NULL(), & !< Black carbon flux from atmosphere [R Z T-1 ~> kg m-2 s-1] + seaice_bc_flux => NULL() !< Black carbon flux from seaice [R Z T-1 ~> kg m-2 s-1] real, pointer, dimension(:,:,:) :: & fracr_cat => NULL(), & !< per-category ice fraction [nondim] @@ -423,6 +428,11 @@ module MOM_forcing_type ! tracer surface flux related diagnostics handles integer :: id_ice_fraction = -1 integer :: id_u10_sqr = -1 + integer :: id_atm_fine_dust_flux = -1 + integer :: id_atm_coarse_dust_flux = -1 + integer :: id_atm_bc_flux = -1 + integer :: id_seaice_dust_flux = -1 + integer :: id_seaice_bc_flux = -1 ! iceberg diagnostic handles integer :: id_ustar_berg = -1 @@ -1542,7 +1552,7 @@ 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, use_glc_runoff) + use_cfcs, use_MARBL_tracers, 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 @@ -1551,8 +1561,18 @@ 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_MARBL_tracers !< If true, allow MARBL related diagnostics logical, optional, intent(in) :: use_glc_runoff !< If true, allow separate glacial runoff diagnostics + logical :: use_cfcs_or_MARBL_tracers + + ! some diagnostics should be registered if either cfc or MARBL tracers are enabled + use_cfcs_or_MARBL_tracers = .false. + if (present(use_cfcs)) & + use_cfcs_or_MARBL_tracers = use_cfcs_or_MARBL_tracers .or. use_cfcs + if (present(use_MARBL_tracers)) & + use_cfcs_or_MARBL_tracers = use_cfcs_or_MARBL_tracers .or. use_MARBL_tracers + ! Clock for forcing diagnostics handles%id_clock_forcing=cpu_clock_id('(Ocean forcing diagnostics)', grain=CLOCK_ROUTINE) @@ -1601,17 +1621,34 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, endif endif - ! See: - if (present(use_cfcs)) then - if (use_cfcs) then - handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & - 'Fraction of cell area covered by sea ice', 'm2 m-2', conversion=1.0) + if (use_cfcs_or_MARBL_tracers) then + handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & + 'Fraction of cell area covered by sea ice', 'm2 m-2', conversion=1.0) - handles%id_u10_sqr = register_diag_field('ocean_model', 'u10_sqr', diag%axesT1, Time, & - 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%L_to_m**2*US%s_to_T**2) - endif + handles%id_u10_sqr = register_diag_field('ocean_model', 'u10_sqr', diag%axesT1, Time, & + 'Wind magnitude at 10m, squared', 'm2 s-2', conversion=US%L_to_m**2*US%s_to_T**2) endif + if (present(use_MARBL_tracers)) then + if (use_MARBL_tracers) then + handles%id_atm_fine_dust_flux = register_diag_field('ocean_model', 'ATM_FINE_DUST_FLUX_CPL', & + diag%axesT1, Time, 'ATM_FINE_DUST_FLUX from cpl', 'kg m-2 s', & + conversion=US%RZ_T_to_kg_m2s) + handles%id_atm_coarse_dust_flux = register_diag_field('ocean_model', 'ATM_COARSE_DUST_FLUX_CPL', & + diag%axesT1, Time, 'ATM_COARSE_DUST_FLUX from cpl', 'kg m-2 s', & + conversion=US%RZ_T_to_kg_m2s) + handles%id_atm_bc_flux = register_diag_field('ocean_model', 'ATM_BLACK_CARBON_FLUX_CPL', & + diag%axesT1, Time, 'ATM_BLACK_CARBON_FLUX from cpl', 'kg m-2 s', & + conversion=US%RZ_T_to_kg_m2s) + + handles%id_seaice_dust_flux = register_diag_field('ocean_model', 'SEAICE_DUST_FLUX_CPL', & + diag%axesT1, Time, 'SEAICE_DUST_FLUX from cpl', 'kg m-2 s', & + conversion=US%RZ_T_to_kg_m2s) + handles%id_seaice_bc_flux = register_diag_field('ocean_model', 'SEAICE_BLACK_CARBON_FLUX_CPL', & + diag%axesT1, Time, 'SEAICE_BLACK_CARBON_FLUX from cpl', 'kg m-2 s', & + conversion=US%RZ_T_to_kg_m2s) + end if + end if handles%id_psurf = register_diag_field('ocean_model', 'p_surf', diag%axesT1, Time, & 'Pressure at ice-ocean or atmosphere-ocean interface', & 'Pa', conversion=US%RL2_T2_to_Pa, cmor_field_name='pso', & @@ -2340,7 +2377,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) ! applied based on the time interval stored in flux_tmp. real :: wt1 ! The relative weight of the previous fluxes [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -2501,6 +2538,84 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) enddo ; enddo endif + ! Forcings introduced for MARBL + ! NOTE: fluxes%salt_flux, %sw, and %p_surf_full are handled above + if (associated(fluxes%nhx_dep) .and. associated(flux_tmp%nhx_dep)) then + do j=jsd,jed ; do i=isd,ied + fluxes%nhx_dep(i,j) = wt1*fluxes%nhx_dep(i,j) + wt2*flux_tmp%nhx_dep(i,j) + enddo ; enddo + endif + if (associated(fluxes%noy_dep) .and. associated(flux_tmp%noy_dep)) then + do j=jsd,jed ; do i=isd,ied + fluxes%noy_dep(i,j) = wt1*fluxes%noy_dep(i,j) + wt2*flux_tmp%noy_dep(i,j) + enddo ; enddo + endif + if (associated(fluxes%atm_co2) .and. associated(flux_tmp%atm_co2)) then + do j=jsd,jed ; do i=isd,ied + fluxes%atm_co2(i,j) = wt1*fluxes%atm_co2(i,j) + wt2*flux_tmp%atm_co2(i,j) + enddo ; enddo + endif + if (associated(fluxes%atm_alt_co2) .and. associated(flux_tmp%atm_alt_co2)) then + do j=jsd,jed ; do i=isd,ied + fluxes%atm_alt_co2(i,j) = wt1*fluxes%atm_alt_co2(i,j) + wt2*flux_tmp%atm_alt_co2(i,j) + enddo ; enddo + endif + if (associated(fluxes%dust_flux) .and. associated(flux_tmp%dust_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%dust_flux(i,j) = wt1*fluxes%dust_flux(i,j) + wt2*flux_tmp%dust_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%iron_flux) .and. associated(flux_tmp%iron_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%iron_flux(i,j) = wt1*fluxes%iron_flux(i,j) + wt2*flux_tmp%iron_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%atm_fine_dust_flux) .and. associated(flux_tmp%atm_fine_dust_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%atm_fine_dust_flux(i,j) = wt1*fluxes%atm_fine_dust_flux(i,j) + wt2*flux_tmp%atm_fine_dust_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%atm_coarse_dust_flux) .and. associated(flux_tmp%atm_coarse_dust_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%atm_coarse_dust_flux(i,j) = wt1*fluxes%atm_coarse_dust_flux(i,j) + wt2*flux_tmp%atm_coarse_dust_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%atm_bc_flux) .and. associated(flux_tmp%atm_bc_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%atm_bc_flux(i,j) = wt1*fluxes%atm_bc_flux(i,j) + wt2*flux_tmp%atm_bc_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%seaice_dust_flux) .and. associated(flux_tmp%seaice_dust_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%seaice_dust_flux(i,j) = wt1*fluxes%seaice_dust_flux(i,j) + wt2*flux_tmp%seaice_dust_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%seaice_bc_flux) .and. associated(flux_tmp%seaice_bc_flux)) then + do j=jsd,jed ; do i=isd,ied + fluxes%seaice_bc_flux(i,j) = wt1*fluxes%seaice_bc_flux(i,j) + wt2*flux_tmp%seaice_bc_flux(i,j) + enddo ; enddo + endif + if (associated(fluxes%fracr_cat) .and. associated(flux_tmp%fracr_cat)) then + do n=1,size(fluxes%fracr_cat,dim=3) ; do j=jsd,jed ; do i=isd,ied + fluxes%fracr_cat(i,j,n) = wt1*fluxes%fracr_cat(i,j,n) + wt2*flux_tmp%fracr_cat(i,j,n) + enddo ; enddo ; enddo + endif + if (associated(fluxes%qsw_cat) .and. associated(flux_tmp%qsw_cat)) then + do n=1,size(fluxes%qsw_cat,dim=3) ; do j=jsd,jed ; do i=isd,ied + fluxes%qsw_cat(i,j,n) = wt1*fluxes%qsw_cat(i,j,n) + wt2*flux_tmp%qsw_cat(i,j,n) + enddo ; enddo ; enddo + endif + if (associated(fluxes%ice_fraction) .and. associated(flux_tmp%ice_fraction)) then + do j=jsd,jed ; do i=isd,ied + fluxes%ice_fraction(i,j) = wt1*fluxes%ice_fraction(i,j) + wt2*flux_tmp%ice_fraction(i,j) + enddo ; enddo + endif + if (associated(fluxes%u10_sqr) .and. associated(flux_tmp%u10_sqr)) then + do j=jsd,jed ; do i=isd,ied + fluxes%u10_sqr(i,j) = wt1*fluxes%u10_sqr(i,j) + wt2*flux_tmp%u10_sqr(i,j) + enddo ; enddo + endif + if (coupler_type_initialized(fluxes%tr_fluxes) .and. & coupler_type_initialized(flux_tmp%tr_fluxes)) & call coupler_type_increment_data(flux_tmp%tr_fluxes, fluxes%tr_fluxes, & @@ -3368,6 +3483,21 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_u10_sqr > 0) .and. associated(fluxes%u10_sqr)) & call post_data(handles%id_u10_sqr, fluxes%u10_sqr, diag) + if ((handles%id_atm_fine_dust_flux > 0) .and. associated(fluxes%atm_fine_dust_flux)) & + call post_data(handles%id_atm_fine_dust_flux, fluxes%atm_fine_dust_flux, diag) + + if ((handles%id_atm_coarse_dust_flux > 0) .and. associated(fluxes%atm_coarse_dust_flux)) & + call post_data(handles%id_atm_coarse_dust_flux, fluxes%atm_coarse_dust_flux, diag) + + if ((handles%id_atm_bc_flux > 0) .and. associated(fluxes%atm_bc_flux)) & + call post_data(handles%id_atm_bc_flux, fluxes%atm_bc_flux, diag) + + if ((handles%id_seaice_dust_flux > 0) .and. associated(fluxes%seaice_dust_flux)) & + call post_data(handles%id_seaice_dust_flux, fluxes%seaice_dust_flux, diag) + + if ((handles%id_seaice_bc_flux > 0) .and. associated(fluxes%seaice_bc_flux)) & + call post_data(handles%id_seaice_bc_flux, fluxes%seaice_bc_flux, diag) + ! remaining boundary terms ================================================== if ((handles%id_psurf > 0) .and. associated(fluxes%p_surf)) & @@ -3528,7 +3658,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug - !These fields should only be allocated when USE_MARBL is activated. + !These fields should only be allocated when USE_MARBL_TRACERS 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) @@ -3537,6 +3667,11 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & 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) + call myAlloc(fluxes%atm_fine_dust_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_coarse_dust_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%atm_bc_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%seaice_dust_flux,isd,ied,jsd,jed, marbl) + call myAlloc(fluxes%seaice_bc_flux,isd,ied,jsd,jed, marbl) ! These fields should only be allocated when receiving multiple ice categories if (present(ice_ncat)) then @@ -3843,6 +3978,11 @@ subroutine deallocate_forcing_type(fluxes) 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%atm_fine_dust_flux)) deallocate(fluxes%atm_fine_dust_flux) + if (associated(fluxes%atm_coarse_dust_flux)) deallocate(fluxes%atm_coarse_dust_flux) + if (associated(fluxes%atm_bc_flux)) deallocate(fluxes%atm_bc_flux) + if (associated(fluxes%seaice_dust_flux)) deallocate(fluxes%seaice_dust_flux) + if (associated(fluxes%seaice_bc_flux)) deallocate(fluxes%seaice_bc_flux) if (associated(fluxes%fracr_cat)) deallocate(fluxes%fracr_cat) if (associated(fluxes%qsw_cat)) deallocate(fluxes%qsw_cat) diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index f10a06fb51..b312cc3a39 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -7,7 +7,7 @@ module MOM_stoch_eos use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL -use MOM_file_parser, only : get_param, param_file_type +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_isopycnal_slopes, only : vert_fill_TS @@ -65,27 +65,32 @@ logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, resta type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. ! local variables + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: i,j MOM_stoch_eos_init = .false. CS%seed = 0 + call log_version(param_file, "MOM_stoch_eos", version, "") call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & - "If true, stochastic perturbations are applied "//& - "to the EOS in the PGF.", default=.false.) + "If true, computes stochastic perturbations that can be applied "//& + "to the EOS in various places.", default=.false.) call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & "Coefficient correlating the temperature gradient "//& "and SGS T variance.", units="nondim", default=-1.0) + if ((CS%stanley_coeff < 0.0) .and. CS%use_stoch_eos) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if STOCH_EOS is true.") call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & "Coefficient a which scales chi in stochastic perturbation of the "//& "SGS T variance.", units="nondim", default=1.0, & - do_not_log=((CS%stanley_coeff<0.0) .or. .not.CS%use_stoch_eos)) + do_not_log=.not.CS%use_stoch_eos) call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T, & - do_not_log=(CS%stanley_coeff<0.0)) + do_not_log=.not.CS%use_stoch_eos) ! Don't run anything if STANLEY_COEFF < 0 if (CS%stanley_coeff >= 0.0) then @@ -261,4 +266,30 @@ subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt) endif end subroutine MOM_calc_varT +!> \namespace mom_stoch_eos +!! +!! This module provides the foundation of the Stanley parameterization (\cite stanley2020) for correcting the +!! computation of density. Density is not a prognostic variable in MOM6; it is computed for various purposes +!! in various places. The correction to this calculation provided by this module has been implemented +!! in some places where density is used, but not all. +!! +!! To use the correction, first set STOCH_EOS=True. Then, choose the constant c from (25) of +!! \cite stanley2020. This is controlled using STANLEY_COEFF. Setting a negative value will +!! result in an error. \cite stanley2020 found a value of 0.2 offline, coarsening from 0.1 to 1 degree +!! resolution. \cite kenigson2022 proposed a value of 0.5 in a 2/3 degree resolution model. +!! +!! Whether the correction is deterministic or stochastic can be controlled using the variable +!! STANLEY_A. Setting this to 0.0 uses the deterministic version, while a value of 1.0 produces +!! the stochastic version. Reducing from 1 to 0 smoothly transitions from stochastic to deterministic. +!! +!! To turn the correction on in various parts of the code, use +!! - USE_STANLEY_PGF=True for the pressure gradient force (cf. \cite kenigson2022) +!! - USE_STANLEY_ISO=True to correct the computation of isopycnal slopes (used in many places) +!! - USE_STANLEY_GM=True to use the parameterization within GM (cf. \cite agarwal2023) +!! - USE_STANLEY_ML=True to use the parameterization within the mixed-layer restratification +!! parameterization. It applies to both the OM4 and Bodner schemes. (cf. \cite agarwal2023) +!! +!! For ensemble simulations, the random number generator seed can be controlled using the parameter +!! SEED_STOCH_EOS + end module MOM_stoch_eos diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 875cbb4693..c43f71481e 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -293,6 +293,7 @@ module MOM_variables ! The following elements are pointers so they can be used as targets for pointers in the restart registry. real, pointer, dimension(:,:) :: MLD => NULL() !< Instantaneous active mixing layer depth [Z ~> m]. + real, pointer, dimension(:,:) :: Lam2 => NULL() !< (Langmuir Number)^-2 [nondim]. real, pointer, dimension(:,:) :: h_ML => NULL() !< Instantaneous active mixing layer thickness [H ~> m or kg m-2]. real, pointer, dimension(:,:) :: sfc_buoy_flx => NULL() !< Surface buoyancy flux (derived) [Z2 T-3 ~> m2 s-3]. real, pointer, dimension(:,:,:) :: Kd_shear => NULL() @@ -367,7 +368,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, sfc_state_in, turns, use_marbl_tracers) + omit_frazil, sfc_state_in, turns, 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. @@ -393,7 +394,7 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! is present, it is used and tr_fields_in is ignored. integer, optional, intent(in) :: turns !< If present, the number of counterclockwise quarter !! turns to use on the new grid. - logical, optional, intent(in) :: use_marbl_tracers !< If true, allocate the space for CO2 flux from MARBL + 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, alloc_fco2 @@ -411,7 +412,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 + alloc_fco2 = .false. ; if (present(use_MARBL_tracers)) alloc_fco2 = use_MARBL_tracers if (sfc_state%arrays_allocated) return diff --git a/src/diagnostics/MOM_diagnose_MLD.F90 b/src/diagnostics/MOM_diagnose_MLD.F90 index b2b231cb37..b24714ba69 100644 --- a/src/diagnostics/MOM_diagnose_MLD.F90 +++ b/src/diagnostics/MOM_diagnose_MLD.F90 @@ -103,7 +103,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke hRef_MLD(:) = ref_h_mld - pRef_MLD(:) = GV%H_to_RZ*GV%g_Earth*ref_h_mld + pRef_MLD(:) = GV%H_to_RZ * GV%Z_to_H * GV%g_Earth * ref_h_mld z_ref_diag(:,:) = 0. EOSdom(:) = EOS_domain(G%HI) @@ -337,6 +337,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, k_bounds is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + use_OM4_iteration = .false. if (present(OM4_iteration)) then use_OM4_iteration = OM4_iteration endif diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index fba33fe0ee..9f37965874 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -1100,7 +1100,8 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in(i,j) = heat_in(i,j) + dt * G%areaT(i,j) * & (fluxes%heat_content_evap(i,j) + fluxes%heat_content_lprec(i,j) + & fluxes%heat_content_cond(i,j) + fluxes%heat_content_fprec(i,j) + & - fluxes%heat_content_lrunoff(i,j) + fluxes%heat_content_frunoff(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)) enddo ; enddo elseif (associated(tv%TempxPmE)) then do j=js,je ; do i=is,ie diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index d8a528f5bf..859072c9d6 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -108,6 +108,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! 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) :: auto_io_layout ! The IO 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 @@ -125,6 +126,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! width of the halos that are updated with each call. logical :: auto_mask_table ! Runtime flag that turns on automatic mask table generator integer :: auto_io_layout_fac ! Used to compute IO layout when auto_mask_table is True. + integer :: target_io_pes ! Target number of IO PEs for when auto_mask_table is True. logical :: mask_table_exists ! True if there is a mask table file logical :: is_MOM_domain ! True if this domain is being set for MOM, and not another component like SIS2. character(len=128) :: inputdir ! The directory in which to find the diag table @@ -326,13 +328,22 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & id_clock_auto_mask = cpu_clock_id('(Ocean gen_auto_mask_table)', grain=CLOCK_ROUTINE) auto_mask_table_fname = "MOM_auto_mask_table" + call get_param(param_file, mdl, "TARGET_IO_PES", target_io_pes, & + "When AUTO_MASKTABLE is enabled, target number of IO PEs. If the given target number "//& + "of IO PEs is not achievable, the target number of IO PEs is set to the nearest smaller "//& + "number of PEs that is achievable.", default=1, layoutParam=.true.) + if (target_io_pes <= 0) then + call MOM_error(FATAL, 'TARGET_IO_PES must be a nonnegative integer.') + endif + ! Auto-generate a mask file and determine the layout call cpu_clock_begin(id_clock_auto_mask) if (is_root_PE()) then call gen_auto_mask_table(n_global, reentrant, tripolar_N, PEs_used, param_file, inputdir, & - auto_mask_table_fname, auto_layout, US) + auto_mask_table_fname, target_io_pes, auto_layout, auto_io_layout, US) endif call broadcast(auto_layout, length=2) + call broadcast(auto_io_layout, length=2) call cpu_clock_end(id_clock_auto_mask) mask_table = auto_mask_table_fname @@ -425,12 +436,20 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Compute a valid IO layout if auto_mask_table is on. Otherwise, read in IO_LAYOUT parameter, if (auto_mask_table) then + ! aa: AUTO_IO_LAYOUT_FAC is fragile and should be deprecated/removed in favor of TARGET_IO_PES. call get_param(param_file, mdl, "AUTO_IO_LAYOUT_FAC", auto_io_layout_fac, & "When AUTO_MASKTABLE is enabled, io layout is calculated by performing integer "//& "division of the runtime-determined domain layout with this factor. If the factor "//& - "is set to 0 (default), the io layout is set to 1,1.", & + "is set to 0 (default), the io layout is set to 1,1. NOTE: TARGET_IO_PES is a more "//& + "robust way to set the number of IO PEs when auto masking is turned on.", & default=0, layoutParam=.true.) - if (auto_io_layout_fac>0) then + if (auto_io_layout_fac>1 .and. target_io_pes>1) then + call MOM_error(FATAL, 'AUTO_IO_LAYOUT_FAC and TARGET_IO_PES cannot be set simultaneously.') + endif + if (target_io_pes>1) then + io_layout(1) = auto_io_layout(1) + io_layout(2) = auto_io_layout(2) + elseif (auto_io_layout_fac>0) then io_layout(1) = max(layout(1)/auto_io_layout_fac, 1) io_layout(2) = max(layout(2)/auto_io_layout_fac, 1) elseif (auto_io_layout_fac<0) then @@ -486,7 +505,8 @@ subroutine MOM_define_layout(n_global, ndivs, layout) end subroutine MOM_define_layout !> Given a desired number of active npes, generate a layout and mask_table -subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, inputdir, filename, layout, US) +subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, & + inputdir, filename, target_io_pes, layout, io_layout, US) integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions logical, dimension(2), intent(in) :: reentrant !< True if the x- and y- directions are periodic. logical, intent(in) :: tripolar_N !< A flag indicating whether there is n. tripolar connectivity @@ -494,7 +514,9 @@ subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters character(len=128), intent(in) :: inputdir !< INPUTDIR parameter character(len=:), allocatable, intent(in) :: filename !< Mask table file path (to be auto-generated.) + integer, intent(inout) :: target_io_pes !< Target number of IO PEs when auto_mask_table is True. integer, dimension(2), intent(out) :: layout !< The generated layout of PEs (incl. masked blocks) + integer, dimension(2), intent(out) :: io_layout !< The generated IO layout based on target_io_pes. type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type ! Local variables @@ -504,21 +526,27 @@ subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file character(len=200) :: topo_varname ! Variable name in file character(len=200) :: topo_config character(len=40) :: mdl = "gen_auto_mask_table" ! This subroutine's name. - integer :: i, j, p + integer :: i, j, p, p_up real :: Dmask ! The depth for masking in the same units as D [Z ~> m] real :: min_depth ! The minimum ocean depth in the same units as D [Z ~> m] real :: mask_depth ! The depth shallower than which to mask a point as land. [Z ~> m] real :: glob_ocn_frac ! ratio of ocean points to total number of points [nondim] - real :: r_p ! aspect ratio for division count p. [nondim] + real :: ar ! layout aspect ratio to check if it is too extreme [nondim] real :: m_to_Z ! A conversion factor from m to height units [Z m-1 ~> 1] integer :: nx, ny ! global domain sizes integer, parameter :: ibuf=2, jbuf=2 real, parameter :: r_extreme = 4.0 ! aspect ratio limit (>1) for a layout to be considered [nondim] integer :: num_masked_blocks integer, allocatable :: mask_table(:,:) + integer :: max_feasible_p ! max division count that leads to enough land block masking to arrive at target compute PEs + real, parameter :: pfrac = 0.01 ! fraction by which to reduce the max_feasible_p if target IO PEs is not achievable. + ! (This is to provide a wiggle room for the target IO PEs to be achieved.) [nondim] + character(len=200) :: mesg ! A string to use for error messages m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + io_layout = [1, 1] + ! Read in params necessary for auto-masking call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & units="m", default=0.0, scale=m_to_Z, do_not_log=.true.) @@ -592,28 +620,56 @@ subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file endif glob_ocn_frac = real(sum(mask(1+ibuf:nx+ibuf, 1+jbuf:ny+jbuf))) / (nx * ny) + max_feasible_p = 0 + + ! Iteratively check for all possible division counts starting from the upper bound of npes/glob_ocn_frac. + ! The first encountered feasible division count is stored in max_feasible_p. If the target_io_pes is not + ! achievable with this layout, the iteration continues until max_feasible_p * (1.0 - pfrac) is reached or the + ! target_io_pes is satisfiable. If not, the target_io_pes is decremented and the iteration is re-done from + ! max_feasible_p to max_feasible_p * (1.0 - pfrac). + outer: do i = target_io_pes, 1, -1 + + if (max_feasible_p == 0) then ! first iteration + p_up = ceiling(npes/glob_ocn_frac) + else ! subsequent iterations with reduced target_io_pes + p_up = max_feasible_p + endif - ! Iteratively check for all possible division counts starting from the upper bound of npes/glob_ocn_frac, - ! which is over-optimistic for realistic domains, but may be satisfied with idealized domains. - do p = ceiling(npes/glob_ocn_frac), npes, -1 - - ! compute the layout for the current division count, p - call MOM_define_layout(n_global, p, layout) - - ! don't bother checking this p if the aspect ratio is extreme - r_p = (real(nx)/layout(1)) / (real(ny)/layout(2)) - if ( r_p * r_extreme < 1 .or. r_extreme < r_p ) cycle - - ! Get the number of masked_blocks for this particular division count - call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks) + do p = p_up, npes, -1 + + ! compute the layout for the current division count, p + call MOM_define_layout(n_global, p, layout) + + ! don't bother checking this p if the aspect ratio is extreme + ar = (real(nx)/layout(1)) / (real(ny)/layout(2)) + if ( ar * r_extreme < 1 .or. r_extreme < ar ) cycle + + ! Get the number of masked_blocks for this particular division count + call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks) + + ! If we can eliminate enough blocks to reach the target compute npes, check if the target IO PEs can also be + ! satisfied with this layout. If so, terminate the whole iteration. + if (p-num_masked_blocks <= npes) then ! We can eliminate enough blocks to reach the target compute npes + if (max_feasible_p == 0) max_feasible_p = p + if (mod(layout(1)*layout(2), i) == 0) then + io_layout = auto_determine_io_layout(layout(1), layout(2), i) + ! skip if aspect ratio is extreme + ar = (real(layout(1))/io_layout(1)) / (real(layout(2))/io_layout(2)) + if ( ar * r_extreme < 1 .or. r_extreme < ar ) cycle + call MOM_error(NOTE, "Found the optimum layout for auto-masking. Terminating iteration.") + if (i /= target_io_pes) then + write(mesg,'(a,i0)') "For compatibility with compute layout, changed number of IO PEs to: ", i + call MOM_error(NOTE, mesg) + endif + exit outer + endif + endif - ! If we can eliminate enough blocks to reach the target npes, adopt - ! this p (and the associated layout) and terminate the iteration. - if (p-num_masked_blocks <= npes) then - call MOM_error(NOTE, "Found the optimum layout for auto-masking. Terminating iteration...") - exit - endif - enddo + ! Do not reduce the division count too much to satisfy the target_io_pes. Instead, re-do the iteration + ! with a reduced target_io_pes. + if (p <= max_feasible_p * (1.0 - pfrac)) exit ! (inner do loop) + enddo + enddo outer if (num_masked_blocks == 0) then call MOM_error(FATAL, "Couldn't auto-eliminate any land blocks. Try to increase the number "//& @@ -702,4 +758,41 @@ subroutine write_auto_mask_file(mask_table, layout, npes, filename) call close_file(file_ascii) end subroutine write_auto_mask_file +!> Computes the io layout based on the domain layout and a target number of IO PEs. +function auto_determine_io_layout(idiv, jdiv, nio) result(best_io_layout) + integer, intent(in) :: idiv ! The number of compute divisions along the x-axis + integer, intent(in) :: jdiv ! The number of compute divisions along the y-axis + integer, intent(in) :: nio ! Target number of IO PEs, s.t., (idiv_io * jdiv_io) % nio == 0 + ! return + integer :: io_layout(2) ! Temporary IO layout + integer :: best_io_layout(2) ! Best IO layout + integer :: f, best_idiv_io, best_jdiv_io + real :: ratio_diff, min_ratio_diff + + if (mod(idiv*jdiv, nio) /= 0) then + call MOM_error(FATAL, "The product of the compute layout must be divisible by the target number of IO PEs.") + endif + + min_ratio_diff = 1.0e30 ! Large initial value + best_io_layout = [1, nio] + + ! Iterate over all factors of nio + do f = 1, nio + if (mod(nio, f) /= 0) cycle + io_layout = [f, nio / f] + + ! Check divisibility constraints + if (mod(idiv, io_layout(1)) == 0 .and. mod(jdiv, io_layout(2)) == 0) then + ratio_diff = abs(real(io_layout(1)) / real(io_layout(2)) - real(idiv) / real(jdiv)) + + ! Update best choice if ratio_diff is smaller + if (ratio_diff < min_ratio_diff) then + min_ratio_diff = ratio_diff + best_io_layout = [io_layout(1), io_layout(2)] + end if + end if + end do + +end function auto_determine_io_layout + end module MOM_domains diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 66d50b9ca0..a2632c7562 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -60,6 +60,7 @@ module MOM_io public :: file_exists, open_ASCII_file, close_file public :: MOM_file, MOM_infra_file, MOM_netcdf_file public :: field_exists, get_filename_appendix +public :: insert_ensemble_appendix public :: fieldtype, field_size, get_field_atts public :: axistype, get_axis_data public :: MOM_read_data, MOM_read_vector, read_field_chksum @@ -2999,6 +3000,47 @@ subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, sc call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) end subroutine MOM_write_field_0d +!> Insert the ensemble appendix into a filename. If provided, the appendix is inserted after +!! the last occurrence of the insert_after substring in the filename. +subroutine insert_ensemble_appendix(filename, insert_after) + character(len=*), intent(inout) :: filename !< The filename to which the appendix is inserted + character(len=*), optional, intent(in) :: insert_after !< The string after which the appendix is inserted. + !! If not provided or found, the appendix is inserted + !! at the end of the filename. + ! Local variables + character(len=32) :: filename_appendix ! ensemble appendix to be inserted into the filename + character(len=:), allocatable :: filename_tr ! trimmed filename + character(len=:), allocatable :: insert_after_tr ! trimmed insert_after + integer :: pos ! The filename string index after which the appendix is to be inserted + + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) == 0) return + + filename_tr = trim(adjustl(filename)) + pos = len(filename_tr) + + ! If insert_after is provided, find the last occurrence of insert_after in the filename and set pos accordingly. + if (present(insert_after)) then + insert_after_tr = trim(adjustl(insert_after)) + pos = index(filename_tr, insert_after_tr, back=.true.) + if (pos == 0) then + call MOM_error(FATAL, "insert_ensemble_appendix: The string " // insert_after_tr // & + " was not found in the filename " // filename_tr) + endif + pos = pos + len(insert_after_tr) - 1 + endif + + ! Insert the ensemble appendix into the filename. If the appendix is to be added to + ! the end of the filename, do so before the .nc extension if it exists. + if (pos>3 .and. pos == len(filename_tr)) then + if (filename_tr(pos-2:pos) == ".nc") then + pos = pos - 3 ! Position before the .nc extension + endif + endif + filename = filename_tr(1:pos) // trim(filename_appendix) // filename_tr(pos+1:) + +end subroutine insert_ensemble_appendix + !> Given filename and fieldname, this subroutine returns the size of the field in the file subroutine field_size(filename, fieldname, sizes, field_found, no_domain, ndims, ncid_in) character(len=*), intent(in) :: filename !< The name of the file to read diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index ef4adb193a..47731ab1c0 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -15,10 +15,11 @@ module MOM_restart use MOM_io, only : create_MOM_file, file_exists use MOM_io, only : MOM_infra_file, MOM_field use MOM_io, only : MOM_read_data, read_data, MOM_write_field, field_exists -use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix +use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE use MOM_io, only : axis_info, get_axis_info +use MOM_io, only : insert_ensemble_appendix use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date @@ -134,6 +135,8 @@ module MOM_restart type(p4d), pointer :: var_ptr4d(:) => NULL() !>@} integer :: max_fields !< The maximum number of restart fields + character(len=32) :: ensemble_appendix_prefix !< The prefix after which the ensemble id appendix is added + !! in output file names. end type MOM_restart_CS !> Register fields for restarts @@ -1653,15 +1656,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif ; endif ! Determine if there is a filename_appendix (used for ensemble runs). - call get_filename_appendix(filename_appendix) - if (len_trim(filename_appendix) > 0) then - length = len_trim(restartname) - if (restartname(length-2:length) == '.nc') then - restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' - else - restartname = restartname(1:length) //'.'//trim(filename_appendix) - endif - endif + call insert_ensemble_appendix(restartname, CS%ensemble_appendix_prefix) next_var = 1 do while (next_var <= CS%novars ) @@ -2133,17 +2128,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, still_looking = (num_restart <= 0) ! Avoid going through the file list twice. do while (still_looking) restartname = trim(CS%restartfile) - - ! Determine if there is a filename_appendix (used for ensemble runs). - call get_filename_appendix(filename_appendix) - if (len_trim(filename_appendix) > 0) then - length = len_trim(restartname) - if (restartname(length-2:length) == '.nc') then - restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' - else - restartname = restartname(1:length) //'.'//trim(filename_appendix) - endif - endif + call insert_ensemble_appendix(restartname, CS%ensemble_appendix_prefix) filepath = trim(directory) // trim(restartname) write(suffix,'("_",I0)') num_restart @@ -2297,6 +2282,12 @@ subroutine restart_init(param_file, CS, restart_root) "made from a run with a different mask_table than the current run, "//& "in which case the checksums will not match and cause crash.",& default=.true.) + call get_param(param_file, mdl, "ENSEMBLE_APPENDIX_PREFIX", CS%ensemble_appendix_prefix, & + "If set to a non-empty string, this value specifies the substring after which "//& + "the ensemble appendix is inserted in restart, initial conditions, and ocean "//& + "geometry file names. If the specified substring is not found in any of those "//& + "output file names, the model terminates with an error.", & + default="") call get_param(param_file, mdl, "RESTART_SYMMETRIC_CHECKSUMS", CS%symmetric_checksums, & "If true, do the restart checksums on all the edge points for a non-reentrant "//& "grid. This requires that SYMMETRIC_MEMORY_ is defined at compile time.", & diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 5ecee4620e..8cdf8156af 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -18,6 +18,7 @@ module MOM_shared_initialization 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 use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc +use MOM_io, only : insert_ensemble_appendix use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -1344,6 +1345,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) 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 + character(len=32) :: ensemble_appendix_prefix ! The prefix after which the ensemble id appendix is added type(vardesc), dimension(:), allocatable :: & vars ! Types with metadata about the variables and their staggering type(MOM_field), dimension(:), allocatable :: & @@ -1356,7 +1358,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) call callTree_enter('write_ocean_geometry_file()') - nFlds = 19 ; if (G%bathymetry_at_vel) nFlds = 23 + nFlds = 23 ; if (G%bathymetry_at_vel) nFlds = 27 allocate(vars(nFlds)) allocate(fields(nFlds)) @@ -1375,28 +1377,32 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) vars(2) = var_desc("geolonb","degree","longitude at corner (Bu) points",'q','1','1') vars(3) = var_desc("geolat","degree", "latitude at tracer (T) points", 'h','1','1') vars(4) = var_desc("geolon","degree","longitude at tracer (T) points",'h','1','1') - vars(5) = var_desc("D","meter","Basin Depth",'h','1','1') - vars(6) = var_desc("f","s-1","Coriolis Parameter",'q','1','1') - vars(7) = var_desc("dxCv","m","Zonal grid spacing at v points",'v','1','1') - vars(8) = var_desc("dyCu","m","Meridional grid spacing at u points",'u','1','1') - vars(9) = var_desc("dxCu","m","Zonal grid spacing at u points",'u','1','1') - vars(10)= var_desc("dyCv","m","Meridional grid spacing at v points",'v','1','1') - vars(11)= var_desc("dxT","m","Zonal grid spacing at h points",'h','1','1') - vars(12)= var_desc("dyT","m","Meridional grid spacing at h points",'h','1','1') - vars(13)= var_desc("dxBu","m","Zonal grid spacing at q points",'q','1','1') - vars(14)= var_desc("dyBu","m","Meridional grid spacing at q points",'q','1','1') - vars(15)= var_desc("Ah","m2","Area of h cells",'h','1','1') - vars(16)= var_desc("Aq","m2","Area of q cells",'q','1','1') - - vars(17)= var_desc("dxCvo","m","Open zonal grid spacing at v points",'v','1','1') - vars(18)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') - vars(19)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') + vars(5) = var_desc("geolatu","degree","latitude at zonal velocity (Cu) points",'u','1','1') + vars(6) = var_desc("geolonu","degree","longitude at zonal velocity (Cu) points",'u','1','1') + vars(7) = var_desc("geolatv","degree","latitude at meridional velocity (Cv) points",'v','1','1') + vars(8) = var_desc("geolonv","degree","longitude at meridional velocity (Cv) points",'v','1','1') + vars(9) = var_desc("D","meter","Basin Depth",'h','1','1') + vars(10)= var_desc("f","s-1","Coriolis Parameter",'q','1','1') + vars(11)= var_desc("dxCv","m","Zonal grid spacing at v points",'v','1','1') + vars(12)= var_desc("dyCu","m","Meridional grid spacing at u points",'u','1','1') + vars(13)= var_desc("dxCu","m","Zonal grid spacing at u points",'u','1','1') + vars(14)= var_desc("dyCv","m","Meridional grid spacing at v points",'v','1','1') + vars(15)= var_desc("dxT","m","Zonal grid spacing at h points",'h','1','1') + vars(16)= var_desc("dyT","m","Meridional grid spacing at h points",'h','1','1') + vars(17)= var_desc("dxBu","m","Zonal grid spacing at q points",'q','1','1') + vars(18)= var_desc("dyBu","m","Meridional grid spacing at q points",'q','1','1') + vars(19)= var_desc("Ah","m2","Area of h cells",'h','1','1') + vars(20)= var_desc("Aq","m2","Area of q cells",'q','1','1') + + vars(21)= var_desc("dxCvo","m","Open zonal grid spacing at v points",'v','1','1') + vars(22)= var_desc("dyCuo","m","Open meridional grid spacing at u points",'u','1','1') + vars(23)= var_desc("wet", "nondim", "land or ocean?", 'h','1','1') if (G%bathymetry_at_vel) then - vars(20) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') - vars(21) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') - vars(22) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') - vars(23) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') + vars(24) = var_desc("Dblock_u","m","Blocked depth at u points",'u','1','1') + vars(25) = var_desc("Dopen_u","m","Open depth at u points",'u','1','1') + vars(26) = var_desc("Dblock_v","m","Blocked depth at v points",'v','1','1') + vars(27) = var_desc("Dopen_v","m","Open depth at v points",'v','1','1') endif if (present(geom_file)) then @@ -1405,16 +1411,13 @@ 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, "ENSEMBLE_APPENDIX_PREFIX", ensemble_appendix_prefix, & + "If set to a non-empty string, this value specifies the substring after which "//& + "the ensemble appendix is inserted in restart, initial conditions, and ocean "//& + "geometry file names. If the specified substring is not found in any of those "//& + "output file names, the model terminates with an error.", & + default="", do_not_log=.true.) + call insert_ensemble_appendix(filepath, ensemble_appendix_prefix) 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 "//& @@ -1431,31 +1434,35 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) call MOM_write_field(IO_handle, fields(3), G%Domain, G%geoLatT) call MOM_write_field(IO_handle, fields(4), G%Domain, G%geoLonT) - - call MOM_write_field(IO_handle, fields(5), G%Domain, G%bathyT, unscale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(6), G%Domain, G%CoriolisBu, unscale=US%s_to_T) - - call MOM_write_field(IO_handle, fields(7), G%Domain, G%dxCv, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(8), G%Domain, G%dyCu, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(9), G%Domain, G%dxCu, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(10), G%Domain, G%dyCv, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxT, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyT, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxBu, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyBu, unscale=US%L_to_m) - - call MOM_write_field(IO_handle, fields(15), G%Domain, G%areaT, unscale=US%L_to_m**2) - call MOM_write_field(IO_handle, fields(16), G%Domain, G%areaBu, unscale=US%L_to_m**2) - - call MOM_write_field(IO_handle, fields(17), G%Domain, G%dx_Cv, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(18), G%Domain, G%dy_Cu, unscale=US%L_to_m) - call MOM_write_field(IO_handle, fields(19), G%Domain, G%mask2dT) + call MOM_write_field(IO_handle, fields(5), G%Domain, G%geoLatCu) + call MOM_write_field(IO_handle, fields(6), G%Domain, G%geoLonCu) + call MOM_write_field(IO_handle, fields(7), G%Domain, G%geoLatCv) + call MOM_write_field(IO_handle, fields(8), G%Domain, G%geoLonCv) + + call MOM_write_field(IO_handle, fields(9), G%Domain, G%bathyT, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(10), G%Domain, G%CoriolisBu, unscale=US%s_to_T) + + call MOM_write_field(IO_handle, fields(11), G%Domain, G%dxCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(12), G%Domain, G%dyCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(13), G%Domain, G%dxCu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(14), G%Domain, G%dyCv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(15), G%Domain, G%dxT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(16), G%Domain, G%dyT, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(17), G%Domain, G%dxBu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(18), G%Domain, G%dyBu, unscale=US%L_to_m) + + call MOM_write_field(IO_handle, fields(19), G%Domain, G%areaT, unscale=US%L_to_m**2) + call MOM_write_field(IO_handle, fields(20), G%Domain, G%areaBu, unscale=US%L_to_m**2) + + call MOM_write_field(IO_handle, fields(21), G%Domain, G%dx_Cv, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(22), G%Domain, G%dy_Cu, unscale=US%L_to_m) + call MOM_write_field(IO_handle, fields(23), G%Domain, G%mask2dT) if (G%bathymetry_at_vel) then - call MOM_write_field(IO_handle, fields(20), G%Domain, G%Dblock_u, unscale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(21), G%Domain, G%Dopen_u, unscale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(22), G%Domain, G%Dblock_v, unscale=US%Z_to_m) - call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(24), G%Domain, G%Dblock_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(25), G%Domain, G%Dopen_u, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(26), G%Domain, G%Dblock_v, unscale=US%Z_to_m) + call MOM_write_field(IO_handle, fields(27), G%Domain, G%Dopen_v, unscale=US%Z_to_m) endif call IO_handle%close() diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 672de2532c..d09592f975 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -90,6 +90,9 @@ module MOM_hor_visc !! that gets backscattered in the Leith+E scheme. [nondim] logical :: smooth_Ah !< If true (default), then Ah and m_leithy are smoothed. !! This smoothing requires a lot of blocking communication. + logical :: taper_leithy !< If true, backscatter coeff is tapered to zero with depth + real :: leithy_depth !< If tapering leith+E, taper is applied below this depth [Z ~> m] + real :: leithy_width !< If tapering leith+E, backscatter is zero below leithy_depth+leithy_width [Z ~> m] logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity. !! KH is the background value. logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic @@ -181,6 +184,9 @@ module MOM_hor_visc dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] dy_dxT !< Pre-calculated dy/dx at h points [nondim] + real, allocatable :: Iwts(:,:) !< Pre-calculated 1./sum_5x5(G%mask2dT) [nondim] + real, allocatable :: Iwts_u(:,:) !< 1/sum_5x5(G%mask2Cu) [nondim] + real, allocatable :: Iwts_v(:,:) !< 1/sum_5x5(G%mask2Cv) [nondim] real, allocatable :: m_const_leithy(:,:) !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] real, allocatable :: m_leithy_max(:,:) !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & @@ -472,6 +478,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] + ! Layer depth. Used to taper Leith+E backscatter coefficient with depth + real, allocatable :: zc(:,:,:) ! depth at center of h cell [Z ~> m] + 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 @@ -649,9 +658,19 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! One call applies the filter twice u_smooth(:,:,k) = u(:,:,k) v_smooth(:,:,k) = v(:,:,k) - call smooth_x9_uv(G, u_smooth(:,:,k), v_smooth(:,:,k), zero_land=.false.) + call smooth_x9_uv(CS, G, u_smooth(:,:,k), v_smooth(:,:,k), zero_land=.false.) enddo call pass_vector(u_smooth, v_smooth, G%Domain) + ! If tapering the backscatter, calculate depths now + if (CS%taper_leithy) then + ! allocate zc + allocate(zc(SZI_(G),SZJ_(G),SZK_(GV))) ; zc(:,:,:) = 0.0 + ! Compute zc. Not actual cell centers because it starts at 0 rather than at SSH. + zc(:,:,1) = 0.5 * h(:,:,1) + do k=2,nz + zc(:,:,k) = zc(:,:,k-1) + 0.5 * (h(:,:,k-1) + h(:,:,k)) + enddo + endif endif if (CS%use_QG_Leith_visc .and. ((CS%Leith_Kh) .or. (CS%Leith_Ah))) then @@ -675,7 +694,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_bh, 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, hu_cont, hv_cont, STOCH & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont, STOCH, zc & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, tmp, & @@ -1237,14 +1256,6 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif - ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. - ! The harmonic component of str_xx is added in the biharmonic loop. - if (CS%use_Leithy) then - do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = 0. - enddo ; enddo - endif - if (CS%id_Kh_h>0 .or. CS%debug) then do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh_h(i,j,k) = Kh(i,j) @@ -1337,14 +1348,17 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, else m_leithy(i,j) = CS%m_leithy_max(i,j) endif - m_leithy(i,j) = G%mask2dBu(i,j) * m_leithy(i,j) + endif + if (CS%taper_leithy) then + ! Multiply m_leithy by taper function of depth + m_leithy(i,j) = m_leithy(i,j) * leithy_taper_function(CS, zc(i,j,k)) endif enddo ; enddo if (CS%smooth_Ah) then ! Smooth m_leithy. A single call smoothes twice. call pass_var(m_leithy, G%Domain, halo=2) - call smooth_x9_h(G, m_leithy, zero_land=.true.) + call smooth_x9_h(CS, G, m_leithy, zero_land=.true.) call pass_var(m_leithy, G%Domain) endif ! Get Ah @@ -1363,7 +1377,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo call pass_var(Ah_sq, G%Domain, halo=2) ! A single call smoothes twice. - call smooth_x9_h(G, Ah_sq, zero_land=.false.) + call smooth_x9_h(CS, G, Ah_sq, zero_land=.false.) call pass_var(Ah_sq, G%Domain) do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah_h(i,j,k) = max(CS%Ah_bg_xx(i,j), sqrt(max(0., Ah_sq(i,j)))) @@ -1425,8 +1439,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, ! Compute Leith+E Kh after bounds have been applied to Ah ! and after it has been smoothed. Kh = -m_leithy * Ah do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh - Kh(i,j) = -m_leithy(i,j) * Ah(i,j) - Kh_h(i,j,k) = Kh(i,j) + Kh_BS(i,j) = -m_leithy(i,j) * Ah(i,j) + BS_coeff_h(i,j,k) = Kh_BS(i,j) enddo ; enddo endif @@ -1445,7 +1459,7 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, str_xx(i,j) = str_xx(i,j) + d_str - if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j) + if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh_BS(i,j) * sh_xx_smooth(i,j) ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j)) @@ -1675,9 +1689,16 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (CS%use_Leithy) then ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points do J=js-1,Jeq ; do I=is-1,Ieq - Kh(I,J) = 0.25 * ((Kh_h(i,j,k) + Kh_h(i+1,j+1,k)) + (Kh_h(i,j+1,k) + Kh_h(i+1,j,k))) + Kh_BS(I,J) = 0.25 * ((BS_coeff_h(i,j ,k) + BS_coeff_h(i+1,j+1,k)) + & + (BS_coeff_h(i,j+1,k) + BS_coeff_h(i+1,j ,k))) enddo ; enddo - end if + endif + + if (CS%id_BS_coeff_q>0) then + do J=js-1,Jeq ; do I=is-1,Ieq + BS_coeff_q(I,J,k) = Kh_BS(I,J) + enddo ; enddo + endif if (CS%id_Kh_q > 0 .or. CS%debug) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1697,13 +1718,13 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, enddo ; enddo endif - if (.not. CS%use_Leithy) then - do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) - enddo ; enddo - else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) + enddo ; enddo + + if (CS%use_Leithy) then do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(I,J) * sh_xy_smooth(I,J) + str_xy(I,J) = str_xy(I,J) - Kh_BS(I,J) * sh_xy_smooth(I,J) enddo ; enddo endif else @@ -2231,6 +2252,9 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, if (CS%id_visc_limit_q_frac>0) call post_data(CS%id_visc_limit_q_frac, visc_limit_q_frac, CS%diag) if (CS%id_visc_limit_h_flag>0) call post_data(CS%id_visc_limit_h_flag, visc_limit_h_flag, CS%diag) if (CS%id_visc_limit_q_flag>0) call post_data(CS%id_visc_limit_q_flag, visc_limit_q_flag, CS%diag) + endif + + if (CS%EY24_EBT_BS .or. CS%use_leithy) then if (CS%id_BS_coeff_h>0) call post_data(CS%id_BS_coeff_h, BS_coeff_h, CS%diag) if (CS%id_BS_coeff_q>0) call post_data(CS%id_BS_coeff_q, BS_coeff_q, CS%diag) endif @@ -2295,6 +2319,8 @@ subroutine horizontal_viscosity(u, v, h, uh, vh, diffu, diffv, MEKE, VarMix, G, CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) endif + if (allocated(zc)) deallocate(zc) + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity. @@ -2543,6 +2569,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity together with a harmonic backscatter.", & default=.false.) + if (CS%EY24_EBT_BS .and. CS%use_Leithy) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "Cannot simultaneously use EY24 EBT backscatter and Leith+E backscatter") + endif call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%biharmonic) @@ -2664,6 +2694,19 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, Ah and m_leithy are smoothed within Leith+E. This requires "//& "lots of blocking communications, which can be expensive", & default=.true., do_not_log=.not.CS%use_Leithy) + call get_param(param_file, mdl, "TAPER_LEITHY", CS%taper_leithy, & + "If true, Leith+E c_K coefficient is tapered to zero"//& + "below a threshold depth", & + default=.false., do_not_log=.not.CS%use_Leithy) + if (CS%taper_leithy) then + call get_param(param_file, mdl, "LEITHY_DEPTH", CS%leithy_depth, & + "Leith+E backscatter starts tapering below this depth.", & + units="m", scale=US%m_to_Z, default=800.0) + call get_param(param_file, mdl, "LEITHY_WIDTH", CS%leithy_width, & + "Leith+E backscatter is zero below LEITHY_DEPTH+LEITHY_WIDTH.", & + units="m", scale=US%m_to_Z, default=400.0) + if (CS%leithy_width <= 0.0) call MOM_error(FATAL,"ERROR: LEITHY_WIDTH must be positive ") + endif if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") @@ -2797,6 +2840,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) allocate(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB), source=0.0) endif if (CS%use_Leithy) then + allocate(CS%Iwts(isd:ied,jsd:jed), source=0.0) + allocate(CS%Iwts_u(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%Iwts_v(isd:ied,JsdB:JedB), source=0.0) allocate(CS%m_const_leithy(isd:ied,jsd:jed), source=0.0) allocate(CS%m_leithy_max(isd:ied,jsd:jed), source=0.0) endif @@ -2951,7 +2997,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 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%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 * & + G%mask2dBu(i,j ) * G%mask2dBu(i-1,j ) * & + G%mask2dBu(i,j-1) * G%mask2dBu(i-1,j-1) 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 @@ -2961,6 +3009,18 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) enddo ; enddo call min_across_PEs(min_grid_sp_h4) + if (CS%use_Leithy) then + do j=js,je ; do i=is,ie; if (G%mask2dT(i,j) > 0.0) then + CS%Iwts(i,j) = 1.0 / (sum_5x5(G%mask2dT(i-2:i+2,j-2:j+2)) + 1.0E-32) + endif ; enddo ; enddo + do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.0) then + CS%Iwts_u(I,j) = 1.0 / (sum_5x5(G%mask2dCu(I-2:I+2,j-2:j+2)) + 1.0E-32) + endif ; enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + CS%Iwts_v(i,J) = 1.0 / (sum_5x5(G%mask2dCv(i-2:i+2,J-2:J+2)) + 1.0E-32) + endif ; enddo ; enddo + endif + do J=js-1,Jeq ; do I=is-1,Ieq grid_sp_q2 = (2.0*CS%dx2q(I,J)*CS%dy2q(I,J)) / (CS%dx2q(I,J)+CS%dy2q(I,J)) grid_sp_q3 = grid_sp_q2*sqrt(grid_sp_q2) @@ -3231,7 +3291,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif - if (CS%EY24_EBT_BS) then + if (CS%EY24_EBT_BS .or. CS%use_leithy) then CS%id_BS_coeff_h = register_diag_field('ocean_model', 'BS_coeff_h', diag%axesTL, Time, & 'Backscatter coefficient at h points', units='m2 s-1', conversion=US%L_to_m**2*US%s_to_T) CS%id_BS_coeff_q = register_diag_field('ocean_model', 'BS_coeff_q', diag%axesBL, Time, & @@ -3257,6 +3317,26 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) end subroutine hor_visc_init +!> leithy_taper_function returns 1 if zc is shallower than leithy_depth; 0 if deeper than +!! leithy_depth+leithy_width; and an interpolating cubic spline in between. +function leithy_taper_function(CS, zc) + type(hor_visc_CS), intent(in) :: CS !< Control structure for horizontal viscosity + real, intent(in) :: zc !< depth of h-cell centersi [Z ~> m] + real :: leithy_taper_function ! Taper function evaluated at zc [nondim] + + ! Local variables + real :: x ! 0 at top of transition and 1 at bottom [nondim] + + x = (zc - CS%leithy_depth) / CS%leithy_width + if (zc <= CS%leithy_depth) then + leithy_taper_function = 1.0 + elseif (zc >= CS%leithy_depth + CS%leithy_width) then + leithy_taper_function = 0.0 + else + leithy_taper_function = (x - 1.0)**2 * (1.0 + 2 * x) + endif +end function leithy_taper_function + !> 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 @@ -3359,12 +3439,33 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) enddo ! s-loop end subroutine smooth_GME +!> Apply a 5x5 weighted sum. In exact arithmetic this is the same as applying a 1:2:1 smoother +!! twice in each direction. The implementation here uses fewer arithmetic operations, and is +!! rotationally symmetric. To obtain the weighted average, divide the result by 256. +function sum_5x5(x) result(sum_x) + implicit none + real, intent(in) :: x(:,:) !< 5x5 array to be summed. Assumed-shape to avoid copies. [arbitrary] + real :: sum_x !< output [same as x] + real :: sum_partial !< scalar holding a partial sum, for convenience + + sum_partial = ((x(1,1) + x(5,5)) + (x(1,5) + x(5,1))) + sum_partial = sum_partial + 6.*((x(3,1) + x(1,3)) + (x(3,5) + x(5,3))) + sum_partial = sum_partial + 36.*x(3,3) + sum_partial = sum_partial + 16.*((x(2,2) + x(4,4)) + (x(2,4) + x(4,2))) + sum_x = 4.*( ((x(1,2) + x(2,1)) + (x(1,4) + x(4,1))) + & + ((x(5,2) + x(2,5)) + (x(5,4) + x(4,5))) ) + sum_x = sum_x + 24.*((x(2,3) + x(3,2)) + (x(4,3) + x(3,4))) + sum_x = sum_x + sum_partial + +end function + !> Apply a 9-point smoothing filter twice to a field staggered at a thickness point to reduce -!! horizontal two-grid-point noise. +!! horizontal two-grid-point noise. Implemented using a single 5x5 pass rather than 3x3 twice. !! Note that this subroutine does not conserve mass, so don't use it in situations where you !! need conservation. Also note that it assumes that the input field has valid values in the !! first two halo points upon entry. -subroutine smooth_x9_h(G, field_h, zero_land) +subroutine smooth_x9_h(CS, G, field_h, zero_land) + type(hor_visc_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field_h !< h-point field to be smoothed [arbitrary] logical, optional, intent(in) :: zero_land !< If present and false, return the average @@ -3373,42 +3474,36 @@ subroutine smooth_x9_h(G, field_h, zero_land) !! land points and include them in the averages. ! Local variables - real :: fh_prev(SZI_(G),SZJ_(G)) ! The value of the h-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 + real :: fh_prev(SZI_(G),SZJ_(G)) ! Copy of the input value of the h-point field [arbitrary] + real :: Iwts_zl = 0.00390625 ! The inverse of the sum of the weights zeroing land, = 1/256 [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land - do s=1,0,-1 - fh_prev(:,:) = field_h(:,:) - ! apply smoothing on field_h using rotationally symmetric expressions. - do j=js-s,je+s ; do i=is-s,ie+s ; if (G%mask2dT(i,j) > 0.0) then - Iwts = 0.0625 - if (.not. zero_land_val) & - Iwts = 1.0 / ( (4.0*G%mask2dT(i,j) + & - ( 2.0*((G%mask2dT(i-1,j) + G%mask2dT(i+1,j)) + & - (G%mask2dT(i,j-1) + G%mask2dT(i,j+1))) + & - ((G%mask2dT(i-1,j-1) + G%mask2dT(i+1,j+1)) + & - (G%mask2dT(i-1,j+1) + G%mask2dT(i+1,j-1))) ) ) + 1.0e-16 ) - field_h(i,j) = Iwts * ( 4.0*G%mask2dT(i,j) * fh_prev(i,j) & - + (2.0*((G%mask2dT(i-1,j) * fh_prev(i-1,j) + G%mask2dT(i+1,j) * fh_prev(i+1,j)) + & - (G%mask2dT(i,j-1) * fh_prev(i,j-1) + G%mask2dT(i,j+1) * fh_prev(i,j+1))) & - + ((G%mask2dT(i-1,j-1) * fh_prev(i-1,j-1) + G%mask2dT(i+1,j+1) * fh_prev(i+1,j+1)) + & - (G%mask2dT(i-1,j+1) * fh_prev(i-1,j+1) + G%mask2dT(i+1,j-1) * fh_prev(i-1,j-1))) )) + fh_prev(:,:) = field_h(:,:) + ! apply smoothing on field_h using rotationally symmetric expressions. + if (zero_land_val) then + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + field_h(i,j) = Iwts_zl * sum_5x5(fh_prev(i-2:i+2,j-2:j+2) * G%mask2dT(i-2:i+2,j-2:j+2)) endif ; enddo ; enddo - enddo + else + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + field_h(i,j) = CS%Iwts(i,j) * sum_5x5(fh_prev(i-2:i+2,j-2:j+2) * G%mask2dT(i-2:i+2,j-2:j+2)) + endif ; enddo ; enddo + endif end subroutine smooth_x9_h !> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce -!! horizontal two-grid-point noise. +!! horizontal two-grid-point noise. Implemented using a single 5x5 pass rather than 3x3 twice. !! 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) +subroutine smooth_x9_uv(CS, G, field_u, field_v, zero_land) + type(hor_visc_CS), intent(in) :: CS !< Control structure 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] @@ -3418,52 +3513,42 @@ subroutine smooth_x9_uv(G, field_u, field_v, zero_land) !! 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 + real :: fu_prev(SZIB_(G),SZJ_(G)) ! Copy of the input value of the u-point field [arbitrary] + real :: fv_prev(SZI_(G),SZJB_(G)) ! Copy of the input value of the v-point field [arbitrary] + real :: Iwts_zl = 0.00390625 ! The inverse of the sum of the weights zeroing land, = 1/256 [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, 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 the original non-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))) )) + fu_prev(:,:) = field_u(:,:) + ! apply smoothing on field_u using the original non-rotationally symmetric expressions. + if (zero_land_val) then + do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.0) then + field_u(I,j) = Iwts_zl * sum_5x5(fu_prev(I-2:I+2,j-2:j+2) * G%mask2dCu(I-2:I+2,j-2:j+2)) endif ; enddo ; enddo + else + do j=js,je ; do I=Isq,Ieq ; if (G%mask2dCu(I,j) > 0.0) then + field_u(I,j) = CS%Iwts_u(I,j) * & + sum_5x5(fu_prev(I-2:I+2,j-2:j+2) * G%mask2dCu(I-2:I+2,j-2:j+2)) + endif ; enddo ; enddo + endif - fv_prev(:,:) = field_v(:,:) - ! apply smoothing on field_v using the original non-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))) )) + fv_prev(:,:) = field_v(:,:) + ! apply smoothing on field_v using the original non-rotationally symmetric expressions. + if (zero_land_val) then + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + field_v(i,J) = Iwts_zl * sum_5x5(fv_prev(i-2:i+2,J-2:J+2) * G%mask2dCv(i-2:i+2,J-2:J+2)) endif ; enddo ; enddo - enddo + else + do J=Jsq,Jeq ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then + field_v(i,J) = CS%Iwts_v(i,J) * & + sum_5x5(fv_prev(i-2:i+2,J-2:J+2) * G%mask2dCv(i-2:i+2,J-2:J+2)) + endif ; enddo ; enddo + endif end subroutine smooth_x9_uv @@ -3503,6 +3588,9 @@ subroutine hor_visc_end(CS) if (allocated(CS%Biharm_const2_xy)) deallocate(CS%Biharm_const2_xy) if (allocated(CS%Biharm6_const_xx)) deallocate(CS%Biharm6_const_xx) if (allocated(CS%Biharm6_const_xy)) deallocate(CS%Biharm6_const_xy) + if (allocated(CS%Iwts)) deallocate(CS%Iwts) + if (allocated(CS%Iwts_u)) deallocate(CS%Iwts_u) + if (allocated(CS%Iwts_v)) deallocate(CS%Iwts_v) if (allocated(CS%m_const_leithy)) deallocate(CS%m_const_leithy) if (allocated(CS%m_leithy_max)) deallocate(CS%m_leithy_max) if (allocated(CS%Re_Ah_const_xx)) deallocate(CS%Re_Ah_const_xx) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 2aa7f041d4..f220d696c8 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1556,6 +1556,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) logical :: mixing_coefs_OBC_bug ! If false, use only interior data for thickness weighting in ! lateral mixing coefficient calculations and to calculate stratification ! and other fields at open boundary condition faces. + logical :: stoch_eos ! Can't use Stanley param here unless stoch_eos is true ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. @@ -1677,15 +1678,13 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "STOCH_EOS", stoch_eos, & + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "USE_STANLEY_ISO", CS%use_stanley_iso, & "If true, turn on Stanley SGS T variance parameterization "// & "in isopycnal slope code.", default=.false.) - if (CS%use_stanley_iso) then - call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & - "Coefficient correlating the temperature gradient and SGS T variance.", & - units="nondim", default=-1.0, do_not_log=.true.) - if (Stanley_coeff < 0.0) call MOM_error(FATAL, & - "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") + if (CS%use_Stanley_ISO .and. .not.stoch_eos) then + call MOM_error(FATAL, "VarMix_init: USE_STANLEY_ISO requires STOCH_EOS") endif call get_param(param_file, mdl, "OBC_NUMBER_OF_SEGMENTS", number_of_OBC_segments, & default=0, do_not_log=.true.) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 6e558bc0c7..4176359f30 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -104,8 +104,12 @@ module MOM_mixed_layer_restrat !! front-length scales read from a file. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. logical :: use_Stanley_ML !< If true, use the Stanley parameterization of SGS T variance + logical :: wave_enhanced_ustar !< If true, enhance ustar using surface waves, following Eq. 28 in Bodner23. + !! Use a Langmuir number if provided. Otherwise, assumes equilibrium + !! surface waves (La-2=11.). real :: ustar_min !< A minimum value of ustar in thickness units to avoid numerical !! problems [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate !! during restratification, rescaled into thickness-based !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] @@ -148,7 +152,7 @@ module MOM_mixed_layer_restrat !> Driver for the mixed-layer restratification parameterization. !! The code branches between two different implementations depending !! on whether the bulk-mixed layer or a general coordinate are in use. -subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux, VarMix, G, GV, US, CS, Lam2) 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 @@ -169,17 +173,29 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux, !! PBL scheme [Z2 T-3 ~> m2 s-3] type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + real, dimension(:,:), optional, pointer :: Lam2 !< (Langmuir Number)^-2 [nondim] + + ! local variables + logical :: haveLam2 !< True if optional Lam2 argument is both present and associated if (.not. CS%initialized) call MOM_error(FATAL, "mixedlayer_restrat: "// & "Module must be initialized before it is used.") + ! Determine if Lam2 should be used + haveLam2 = .false. + if (present(Lam2)) haveLam2 = associated(Lam2) + if (GV%nkml>0) then ! Original form, written for the isopycnal model with a bulk mixed layer call mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) elseif (CS%use_Bodner) then ! Implementation of Bodner et al., 2023 - call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux) + if (haveLam2) then + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux, Lam2) + else + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux) + endif else ! Implementation of Fox-Kemper et al., 2008, to work in general coordinates call mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, G, GV, US, CS) @@ -754,7 +770,7 @@ end function mu !> Calculates a restratifying flow in the mixed layer, following the formulation !! used in Bodner et al., 2023 (B22) -subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, h_MLD, bflux) +subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, h_MLD, bflux, Lam2) ! Arguments type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -775,6 +791,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !! the PBL scheme [H ~> m or kg m-2] real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the !! PBL scheme [Z2 T-3 ~> m2 s-3] + real, dimension(:,:), optional, pointer :: Lam2 !< (Langmuir Number)^-2, which is defined as + !! Surface Stokes/ustar [nondim] + ! Local variables real :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! zonal mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! merid mixed layer transport [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -807,6 +826,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: w_star3 ! Cube of turbulent convective velocity [Z3 T-3 ~> m3 s-3] real :: u_star3 ! Cube of surface friction velocity [Z3 T-3 ~> m3 s-3] + real :: E_ustar ! Surface wave ustar enhancement factor [nondim] real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: f_h ! Coriolis parameter at h-points [T-1 ~> s-1] @@ -830,10 +850,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! fractional power [T3 m3 Z-3 s-3 ~> 1] real :: m2_s2_to_Z2_T2 ! Conversion factors to restore scaling after a term is raised to a ! fractional power [Z2 s2 T-2 m-2 ~> 1] + real, parameter :: Lam2_eq = 11. ! (Langmuir Number)^-2 assuming wind wave equilibrium [nondim] real, parameter :: two_thirds = 2./3. ! [nondim] logical :: line_is_empty, keep_going integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + logical :: Lam2_available 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 @@ -845,7 +867,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. varS(:) = 0.0 ! Ditto. - ! This value is roughly (pi / (the age of the universe) )^2. + ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "mixedlayer_restrat_Bodner: "// & @@ -860,6 +882,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d "To use the Bodner et al., 2023, MLE parameterization, either MLE_USE_PBL_MLD or "// & "Bodner_detect_MLD must be True.") endif + if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, & + "MOM_mixedlayer_restrat: The Stanley parameterization is not"//& + "available without the Boussinesq approximation.") if (associated(bflux)) & call pass_var(bflux, G%domain, halo=1) @@ -867,6 +892,25 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! Extract the friction velocity from the forcing type. call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + Lam2_available = present(Lam2) + if (Lam2_available) Lam2_available = associated(Lam2) + + ! Wave Enhanced of ustar following Eq. 28 in Bodner23 + if (CS%wave_enhanced_ustar) then + if (Lam2_available) then + do j=js-1,je+1 ; do i=is-1,ie+1 + E_ustar = sqrt( 1.0 + (Lam2(i,j) * 0.104) + (Lam2(i,j) * Lam2(i,j) * 0.00118)) + U_star_2d(i,j) = E_ustar * U_star_2d(i,j) + enddo ; enddo + else + ! Assuming wind wave equilibrium (Lam2=11) + E_ustar = sqrt( 1.0 + (Lam2_eq * 0.104) + (Lam2_eq * Lam2_eq * 0.00118)) + do j=js-1,je+1 ; do i=is-1,ie+1 + U_star_2d(i,j) = E_ustar * U_star_2d(i,j) + enddo ; enddo + endif + endif + if (CS%debug) then call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, unscale=GV%H_to_mks) call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, unscale=US%Z_to_m) @@ -999,7 +1043,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !$OMP default(shared) & !$OMP private(i, j, k, keep_going, line_is_empty, dh, & !$OMP grid_dsd, absf, h_sml, h_big, grd_b, r_wpup, psi_mag, IhTot, & - !$OMP sigint, muzb, muza, hAtVel, Rml_int, SpV_int) + !$OMP sigint, muzb, muza, hAtVel, Rml_int, SpV_int, rho_ml, SpV_ml, dmu ) !$OMP do do j=js-1,je+1 @@ -1630,8 +1674,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. [kg T s-1 H-1 L-2 ~> kg m-3 or 1] real :: omega ! The Earth's rotation rate [T-1 ~> s-1]. real :: ustar_min_dflt ! The default value for RESTRAT_USTAR_MIN [Z T-1 ~> m s-1] - 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 ! This include declares and sets the variable "version". character(len=200) :: inputdir ! The directory where NetCDF input files @@ -1639,6 +1681,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, character(len=128) :: mle_fl_file ! Data containing MLE front-length scale. Used ! when reading from file. character(len=32) :: fl_varname ! Name of front-length scale variable in mle_fl_file. + logical :: stoch_eos ! Can't use Stanley param here unless stoch_eos is true # include "version_variable.h" integer :: i, j @@ -1675,6 +1718,14 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=.true.) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "STOCH_EOS", stoch_eos, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & + "If true, turn on Stanley SGS T variance parameterization "// & + "in ML restrat code.", default=.false.) + if (CS%use_Stanley_ML .and. .not.stoch_eos) then + call MOM_error(FATAL, "mixedlayer_restrat_init: USE_STANLEY_ML requires STOCH_EOS") + endif call openParameterBlock(param_file,'MLE') ! Prepend MLE% to all parameters if (GV%nkml==0) then call get_param(param_file, mdl, "USE_BODNER23", CS%use_Bodner, & @@ -1730,15 +1781,18 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "The default is less than the molecular viscosity of water times the Coriolis "//& "parameter a micron away from the equator.", & units="m2 s-2", default=1.0e-24, scale=US%m_to_Z**2*US%T_to_s**2) + call get_param(param_file, mdl, "WAVE_ENHANCED_USTAR", CS%wave_enhanced_ustar, & + "If true, enhance ustar using surface waves, following Eq. 28 in Bodner23. " //& + "Use a Langmuir number if provided. Otherwise, assumes equilibrium "// & + "surface waves (La-2=11.).", default=.false.) call get_param(param_file, mdl, "TAIL_DH", CS%MLE_tail_dh, & "Fraction by which to extend the mixed-layer restratification "//& "depth used for a smoother stream function at the base of "//& "the mixed-layer.", units="nondim", default=0.0) - call get_param(param_file, mdl, "USE_STANLEY_TVAR", CS%use_Stanley_ML, & - "If true, turn on Stanley SGS T variance parameterization "// & - "in ML restrat code.", default=.false.) call get_param(param_file, mdl, "USE_CR_GRID", CS%Cr_grid, & - "If true, read in a spatially varying Cr field.", default=.false.) + "If true, read in a spatially varying Cr field." //& + "If CR = 0 (default), this field is scaled by 1.0." //& + "If CR>0., this field works as a mask and is scaled by CR.", default=.false.) call get_param(param_file, mdl, "USE_MLD_GRID", CS%MLD_grid, & "If true, read in a spatially varying MLD_decaying_Tfilt field.", default=.false.) if (CS%MLD_grid) then @@ -1762,7 +1816,13 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "The variable name for Cr field.", & default="Cr") filename = trim(inputdir) // "/" // trim(filename) - call MOM_read_data(filename, varname, CS%Cr_space, G%domain) + if (CS%Cr > 0.0) then + ! here, the file is working as a mask + call MOM_read_data(filename, varname, CS%Cr_space, G%domain, scale=CS%Cr) + else + ! read actual Cr + call MOM_read_data(filename, varname, CS%Cr_space, G%domain, scale=1.0) + endif call pass_var(CS%Cr_space, G%domain) endif call closeParameterBlock(param_file) ! The remaining parameters do not have MLE% prepended @@ -1794,17 +1854,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "geostrophic kinetic energy or 1 plus the square of the "//& "grid spacing over the deformation radius, as detailed "//& "by Fox-Kemper et al. (2011)", units="nondim", default=0.0) - ! These parameters are only used in the OM4-era version of Fox-Kemper - call get_param(param_file, mdl, "USE_STANLEY_ML", CS%use_Stanley_ML, & - "If true, turn on Stanley SGS T variance parameterization "// & - "in ML restrat code.", default=.false.) - if (CS%use_Stanley_ML) then - call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & - "Coefficient correlating the temperature gradient and SGS T variance.", & - units="nondim", default=-1.0, do_not_log=.true.) - if (Stanley_coeff < 0.0) call MOM_error(FATAL, & - "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") - endif call get_param(param_file, mdl, 'VON_KARMAN_CONST', CS%vonKar, & 'The value the von Karman constant as used for mixed layer viscosity.', & units='nondim', default=0.41) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index fc61bd0788..1c7fe38155 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -99,9 +99,6 @@ module MOM_thickness_diffuse !! When this is true, it breaks rotational symmetry. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. - real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean - !! temperature gradient in the deterministic part of the Stanley parameterization. - !! Negative values disable the scheme. [nondim] logical :: read_khth !< If true, read a file containing the spatially varying horizontal !! isopycnal height diffusivity logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse @@ -2197,6 +2194,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! available. logical :: use_meke = .false. ! If true, use the MEKE formulation for the thickness diffusivity. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. + logical :: stoch_eos ! Can't use Stanley param here unless stoch_eos is true integer :: i, j CS%initialized = .true. @@ -2324,15 +2322,13 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "streamfunction formulation, expressed as a fraction of planetary "//& "rotation, OMEGA. This should be tiny but non-zero to avoid degeneracy.", & default=1.e-15, units="nondim", scale=US%Z_to_L, do_not_log=.not.CS%use_FGNV_streamfn) + call get_param(param_file, mdl, "STOCH_EOS", stoch_eos, & + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "USE_STANLEY_GM", CS%use_stanley_gm, & "If true, turn on Stanley SGS T variance parameterization "// & "in GM code.", default=.false.) - if (CS%use_stanley_gm) then - call get_param(param_file, mdl, "STANLEY_COEFF", Stanley_coeff, & - "Coefficient correlating the temperature gradient and SGS T variance.", & - units="nondim", default=-1.0, do_not_log=.true.) - if (Stanley_coeff < 0.0) call MOM_error(FATAL, & - "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") + if (CS%use_Stanley_GM .and. .not.stoch_eos) then + call MOM_error(FATAL, "thickness_diffuse_init: USE_STANLEY_GM requires STOCH_EOS") endif call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 8e56ec3ef2..42301f60c7 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -10,22 +10,23 @@ module MOM_stochastics ! particular version wraps all of the calls for MOM6 in the calls that had ! been used for MOM4. ! +use MOM_coms, only : Get_PElist 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_domains, only : root_PE, num_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave use MOM_file_parser, only : get_param, log_version, close_param_file, param_file_type -use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain -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_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, EOS_domain use stochastic_physics, only : init_stochastic_physics_ocn, run_stochastic_physics_ocn +use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain +use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain #include @@ -57,12 +58,18 @@ module MOM_stochastics !! 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. + integer :: answer_date !< The vintage of the order of arithmetic in the stochastics + !! calculations. Values below 20250701 recover the answers from + !! early in 2025, while higher values use expressions that have been + !! refactored for rotational symmetry, including with FMAs enabled. + ! 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 + !! tendencies with a number between 0 and 2 [nondim] + real, allocatable :: skeb_wts(:,:) !< Random pattern of lengthscales for ocean SKEB in mks units [m] + !! Note that SKEB_wts is set via external code in mks units. + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation [nondim] + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation [nondim] 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 @@ -72,15 +79,20 @@ module MOM_stochastics real, allocatable :: taperCv(:,:) !< Taper applied to v component of stochastic !! velocity increment range [0,1], [nondim] + ! Weights for smoothing skeb_diss + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: Isum_area_wts, & !< One over the 3x3 sum of area_wt [L-2 ~> m-2] + area_wt !< Masked h cell areas. [L2 ~> m2] + end type stochastic_CS contains -!! This subroutine initializes the stochastics physics control structure. -subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) +!> This subroutine initializes the stochastics physics control structure. +subroutine stochastics_init(dt, grid, GV, US, CS, param_file, diag, Time) real, intent(in) :: dt !< time step [T ~> s] type(ocean_grid_type), intent(in) :: grid !< horizontal grid information type(verticalGrid_type), intent(in) :: GV !< vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(stochastic_CS), pointer, intent(inout) :: CS !< stochastic control structure type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output @@ -94,10 +106,13 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: pe_zero ! root pe integer :: nxT, nxB ! number of x-points including halo integer :: nyT, nyB ! number of y-points including halo + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: i, j, k ! loop indices - real :: tmp(grid%isdB:grid%iedB,grid%jsdB:grid%jedB) ! Used to construct tapers + real :: tmp(grid%isdB:grid%iedB,grid%jsdB:grid%jedB) ! Used to construct tapers and weights integer :: taper_width ! Width (in cells) of the taper that brings the stochastic velocity ! increments to 0 at the boundary. + real :: sum_area_wts ! A rotationally symmetric sum of the surrounding area weights + ! that are used to filter skeb_diss [L2 ~> m2] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -153,6 +168,14 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) "production and dissipation terms. Amplitude and correlations are "//& "controlled by the nam_stoch namelist in the UFS model only.", & default=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "STOCHASTICS_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic in the stochastics calculations. "//& + "Values below 20250701 recover the answers from early in 2025, while higher "//& + "values use expressions that have been refactored for rotational symmetry.", & + default=20250101) !### Change to: default=default_answer_date) if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) then num_procs = num_PEs() @@ -163,7 +186,7 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) nyT = grid%jed - grid%jsd + 1 nxB = grid%iedB - grid%isdB + 1 nyB = grid%jedB - grid%jsdB + 1 - call init_stochastic_physics_ocn(dt, grid%geoLonT, grid%geoLatT, nxT, nyT, GV%ke, & + call init_stochastic_physics_ocn(dt*US%T_to_s, grid%geoLonT, grid%geoLatT, nxT, nyT, GV%ke, & grid%geoLonBu, grid%geoLatBu, nxB, nyB, & CS%pert_epbl, CS%do_sppt, CS%do_skeb, pe_zero, mom_comm, iret) if (iret/=0) then @@ -171,10 +194,10 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) return endif - if (CS%do_sppt) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) + if ((CS%do_sppt) .or. (CS%do_skeb)) allocate(CS%sppt_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) 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 + if ((CS%pert_epbl) .or. (CS%do_skeb)) then allocate(CS%epbl1_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) allocate(CS%epbl2_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) endif @@ -183,23 +206,23 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) CS%id_sppt_wts = register_diag_field('ocean_model', 'sppt_pattern', CS%diag%axesT1, 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') + 'random pattern for skeb', 'm', conversion=1.0) ! SKEB_wts is set in external code in mks units of [m] 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_skebu = register_diag_field('ocean_model', 'skebu', CS%diag%axesCuL, Time, & - 'zonal current perts', 'None') + 'zonal current perts', 'm s-1', conversion=US%L_T_to_m_s) CS%id_skebv = register_diag_field('ocean_model', 'skebv', CS%diag%axesCvL, Time, & - 'zonal current perts', 'None') + 'zonal current perts', 'm s-1', conversion=US%L_T_to_m_s) CS%id_diss = register_diag_field('ocean_model', 'skeb_amp', CS%diag%axesTL, Time, & - 'SKEB amplitude', 'm s-1') + 'SKEB amplitude', 'm s-1', conversion=US%L_T_to_m_s) CS%id_psi = register_diag_field('ocean_model', 'psi', CS%diag%axesBL, Time, & - 'stream function', 'None') + 'stream function', 'm2 s-1', conversion=US%L_T_to_m_s*US%L_to_m) CS%id_skeb_taperu = register_static_field('ocean_model', 'skeb_taper_u', CS%diag%axesCu1, & - 'SKEB taper u', 'None', interp_method='none') + 'SKEB taper u', 'None', conversion=1.0, 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') + 'SKEB taper v', 'None', conversion=1.0, 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. @@ -242,6 +265,21 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) 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.) + ! Initialize the smoothing weights + if ((CS%do_skeb) .and. CS%skeb_npass >= 1) then + ALLOC_(CS%area_wt(grid%isd:grid%ied,grid%jsd:grid%jed)) ; CS%area_wt(:,:) = 0.0 + ALLOC_(CS%Isum_area_wts(grid%isd:grid%ied,grid%jsd:grid%jed)) ; CS%Isum_area_wts(:,:) = 0.0 + do j=grid%jsc-2,grid%jec+2 ; do i=grid%isc-2,grid%iec+2 + CS%area_wt(i,j) = grid%mask2dT(i,j)*grid%areaT(i,j) + enddo ; enddo + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + sum_area_wts = CS%area_wt(i,j) + & + (((CS%area_wt(i-1,j) + CS%area_wt(i+1,j)) + (CS%area_wt(i,j-1) + CS%area_wt(i,j+1))) + & + ((CS%area_wt(i-1,j-1) + CS%area_wt(i+1,j+1)) + (CS%area_wt(i-1,j+1) + CS%area_wt(i+1,j-1)))) + CS%Isum_area_wts(i,j) = 1.0 / (sum_area_wts + 1.e-16*US%m_to_L**2) + enddo ; enddo + endif + if (CS%do_sppt .OR. CS%pert_epbl .OR. CS%do_skeb) & call MOM_mesg(' === COMPLETED MOM STOCHASTIC INITIALIZATION =====') @@ -249,47 +287,49 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) end subroutine stochastics_init -!> update_ocean_model uses the forcing in Ice_ocean_boundary to advance the -!! ocean model's state from the input value of Ocean_state (which must be for -!! time time_start_update) for a time interval of Ocean_coupling_time_step, -!! returning the publicly visible ocean surface properties in Ocean_sfc and -!! storing the new ocean properties in Ocean_state. +!> Advances the stochastic patterns one time step subroutine update_stochastics(CS) type(stochastic_CS), intent(inout) :: CS !< diabatic control structure 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%skeb_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") end subroutine update_stochastics -subroutine apply_skeb(grid,GV,CS,uc,vc,thickness,tv,dt,Time_end) +!> Adds a stochastic increment (backscatter) to the input velocity field +subroutine apply_skeb(grid, GV, US, 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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, dimension(SZIB_(grid),SZJB_(grid),SZK_(GV)) :: psi !< Streamfunction for stochastic velocity increments - !! [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(grid),SZJ_(grid) ,SZK_(GV)) :: ustar !< Stochastic u velocity increment [L T-1 ~> m s-1] - real, dimension(SZI_(grid) ,SZJB_(grid),SZK_(GV)) :: vstar !< Stochastic v velocity increment [L T-1 ~> m s-1] - real, dimension(SZI_(grid),SZJ_(grid)) :: diss_tmp !< Temporary array used in smoothing skeb_diss - !! [L2 T-3 ~> m2 s-2] - real, dimension(3,3) :: local_weights !< 3x3 stencil weights used in smoothing skeb_diss - !! [L2 ~> m2] - - real :: shr,ten,tot,kh - integer :: i,j,k,iter + + ! local variables + real, dimension(SZIB_(grid),SZJB_(grid),SZK_(GV)) :: psi !< Streamfunction for stochastic velocity increments + !! [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(grid),SZJ_(grid) ,SZK_(GV)) :: ustar !< Stochastic u velocity increment [L T-1 ~> m s-1] + real, dimension(SZI_(grid) ,SZJB_(grid),SZK_(GV)) :: vstar !< Stochastic v velocity increment [L T-1 ~> m s-1] + real, dimension(SZI_(grid),SZJ_(grid)) :: diss_tmp !< Temporary array used in smoothing skeb_diss + !! [L2 T-3 ~> m2 s-2] + real, dimension(3,3) :: local_weights !< 3x3 stencil weights used in smoothing skeb_diss + !! [L2 ~> m2] + + real :: shr ! Horizonal shear [T-1 ~> s-1] + real :: ten ! Horizonal tension of the flow [T-1 ~> s-1] + real :: tot ! The magnitude of the combined shear and tension [T-1 ~> s-1] + real :: kh ! A smooothing factor [nondim] + real :: sum_wtd_skeb_diss ! The rotationally symmetric sum of the surrounding values of skeb times + ! the area weights used to filter skeb_diss [L4 T-3 ~> m4 s-3] + 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") @@ -302,53 +342,81 @@ subroutine apply_skeb(grid,GV,CS,uc,vc,thickness,tv,dt,Time_end) 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 + ! kh needs to be scaled + kh = 1.0 !(120*111)**2 + if (CS%answer_date < 20250701) then + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do i=grid%isc,grid%iec + ! Shear in [T-1 ~> s-1] + 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 in [T-1 ~> s-1] + 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 + else ! This version has parentheses to preserve rotational symmetry when FMAs are enabled. + do k=1,GV%ke + do j=grid%jsc,grid%jec ; do i=grid%isc,grid%iec + ! Shear in [T-1 ~> s-1] + 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 in [T-1 ~> s-1] + 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 + endif ! Sets CS%skeb_diss in [L2 T-3 ~> m2 s-3] 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 + if (CS%answer_date < 20250701) then + ! Do the filter with expressions that do not preserve rotational symmetry. + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + local_weights(:,:) = CS%area_wt(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*US%m_to_L**2) + enddo ; enddo + else + ! This spatial filter preserves rotational symmeetry (including with FMAs), but is + ! mathematically equivalent to the older sum-based form above + do j=grid%jsc-1,grid%jec+1 ; do i=grid%isc-1,grid%iec+1 + sum_wtd_skeb_diss = CS%skeb_diss(i,j,k) * CS%area_wt(i+1,j) + & + ((( (CS%skeb_diss(i-1,j,k) * CS%area_wt(i-1,j)) + (CS%skeb_diss(i+1,j,k) * CS%area_wt(i+1,j)) ) + & + ( (CS%skeb_diss(i,j-1,k) * CS%area_wt(i,j-1)) + (CS%skeb_diss(i,j+1,k) * CS%area_wt(i,j+1)) )) + & + (( (CS%skeb_diss(i-1,j-1,k) * CS%area_wt(i-1,j-1)) + (CS%skeb_diss(i-1,j-1,k) * CS%area_wt(i+1,j+1)) ) + & + ( (CS%skeb_diss(i-1,j+1,k) * CS%area_wt(i-1,j+1)) + (CS%skeb_diss(i+1,j-1,k) * CS%area_wt(i+1,j-1)) ))) + diss_tmp(i,j) = sum_wtd_skeb_diss * CS%Isum_area_wts(i,j) + enddo ; enddo + endif 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) + CS%skeb_diss(i,j,k) = grid%mask2dT(i,j) * 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) + ! call hchksum(CS%skeb_diss, "SKEB DISS", grid%HI, haloshift=2, unscale=US%L_T_to_m_s**2*US%s_to_T) + ! call qchksum(CS%skeb_wts, "SKEB WTS", grid%HI, haloshift=1) ! SKEB_wts comes in from external code in mks units. do k=1,GV%ke do J=grid%jscB-1,grid%jecB ; do I=grid%iscB-1,grid%iecB + ! psi has units of [L2 T-1 ~> m2 s-1] because skeb_wts is in mks units of [m]. 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) + * US%m_to_L*CS%skeb_wts(I,J) enddo ; enddo enddo - !call qchksum(psi,"SKEB PSI", grid%HI, haloshift=1) + !call qchksum(psi,"SKEB PSI", grid%HI, haloshift=1, unscale=US%L_T_to_m_s*US%L_to_m) !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 @@ -361,7 +429,7 @@ subroutine apply_skeb(grid,GV,CS,uc,vc,thickness,tv,dt,Time_end) enddo ; enddo enddo - !call uvchksum("SKEB increment [uv]", ustar, vstar, grid%HI) + !call uvchksum("SKEB increment [uv]", ustar, vstar, grid%HI, unscale=US%L_T_to_m_s) call enable_averages(dt, Time_end, CS%diag) if (CS%id_diss > 0) then @@ -393,7 +461,7 @@ end subroutine apply_skeb !! 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(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 @@ -449,6 +517,33 @@ subroutine smooth_x9_uv(G, field_u, field_v, zero_land) enddo end subroutine smooth_x9_uv - +!> \namespace mom_stochastics +!! +!! This file contains subroutines that implement some stochastic parameterizations in MOM6. +!! SPPT perturbations of the tendencies of S and T are turned on using DO_SPPT=True. +!! Stochastic perturbations in ePBL are turned on using PERT_EPBL=True. +!! Stochastic kinetic energy backscatter (SKEB) via the Stochastic GM+E scheme is turned on using +!! DO_SKEB=True. For all three schemes the spatial and temporal correlation structure +!! of the associated random fields is controlled from the nam_stochy namelist used by +!! the external stochastic_physics package, which is called by subroutines in this +!! module. +!! +!! The SKEB backscatter can be set in a variety of ways. If SKEB_USE_GM=True then +!! SKEB_GM_COEF times the GM work rate will be added to the backscatter rate. (The +!! vertical structure for this component of backscatter is the so-called EBT struct.) If +!! SKEB_USE_FRICT=True then SKEB_FRICT_COEF times the work rate from +!! lateral viscosity will be added to the backscatter rate. The code uses the total contribution +!! from Laplacian and biharmonic viscosities as computed within the horizontal viscosity module. +!! If neither SKEB_USE_GM nor SKEB_USE_FRICT is true, then the code +!! computes the dissipation rate as if it came from a lateral harmonic viscosity with +!! coefficient 1 (MKS units). The only thoroughly tested SKEB option at this point is +!! SKEB_USE_GM. +!! +!! The contributions to the backscatter rate are smoothed before use. One smoothing pass uses a +!! 3x3 moving average with weights proportional to the h-cell areas. The number of smoothing passes +!! is controlled by SKEB_NPASS. +!! +!! A taper is applied to the SKEB velocity increments (equivalently to the SKEB stochastic forcing). +!! The taper zeros out the increments near land cells. The width of this taper can be controlled using +!! SKEB_TAPER_WIDTH. end module MOM_stochastics - diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 6bbe582ce3..e0cf922c68 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -34,6 +34,7 @@ module MOM_CVMix_KPP 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 +use CVMix_kpp, only : CVMix_kpp_compute_ER_depth implicit none ; private @@ -48,6 +49,8 @@ module MOM_CVMix_KPP public :: KPP_NonLocalTransport_saln public :: KPP_NonLocalTransport public :: KPP_get_BLD +public :: KPP_get_Lam2 + ! Enumerated constants integer, private, parameter :: NLT_SHAPE_CVMix = 0 !< Use the CVMix profile @@ -124,6 +127,9 @@ module MOM_CVMix_KPP real :: MLD_guess_min !< The minimum estimate of the mixed layer depth used to !! calculate the Langmuir number for Langmuir turbulence !! enhancement with KPP [Z ~> m] + real :: KPP_ER_Cb !< Entrainment Rule TKE buoyancy production weight [nondim] + real :: KPP_ER_Cs !< Entrainment Rule TKE Stokes production weight [nondim] + real :: KPP_ER_Cu !< Entrainment Rule TKE shear production weight [nondim] logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient !! This is relevant for which current to use in RiB integer :: answer_date !< The vintage of the order of arithmetic in the CVMix KPP @@ -149,39 +155,49 @@ module MOM_CVMix_KPP integer :: id_NLTt = -1 integer :: id_NLTs = -1 integer :: id_EnhK = -1, id_EnhVt2 = -1 - integer :: id_EnhW = -1 integer :: id_La_SL = -1 integer :: id_OBLdepth_original = -1 + integer :: id_ERdepth = -1, id_RNdepth = -1 integer :: id_StokesXI = -1 + integer :: id_BEdE_ER = -1 integer :: id_Lam2 = -1 + integer :: id_PU_TKE = -1 + integer :: id_PS_TKE = -1 + integer :: id_PB_TKE = -1 !>@} ! Diagnostics arrays real, pointer, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [Z ~> m] - real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL without smoothing [Z ~> m] - real, allocatable, dimension(:,:) :: StokesParXI !< Stokes similarity parameter [nondim] - real, allocatable, dimension(:,:) :: Lam2 !< La^(-2) = Ustk0/u* [nondim] - 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] - real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] - real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [L2 T-2 ~> m2 s-2] + real, pointer, dimension(:,:) :: Lam2 !< La^(-2) = Ustk0/u* [nondim] real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer [nondim] - real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] - real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [Z T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [T-1 ~> s-1] real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] - real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for - !! bulk Ri [Z2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved turbulence velocity^2 for bulk Ri [Z2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [L2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] + real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] + real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [Z2 T-1 ~> m2 s-1] real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [Z2 T-1 ~> m2 s-1] real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [Z2 T-1 ~> m2 s-1] - real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [Z2 T-1 ~> m2 s-1] real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [C ~> degC] real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [S ~> ppt] real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [L T-1 ~> m s-1] real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient [nondim] real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 [nondim] + real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [Z ~> m] without smoothing + real, allocatable, dimension(:,:) :: ERdepth !< Percent use ER boundary layer depth [nondim] + real, allocatable, dimension(:,:) :: RNdepth !< Percent use Ri Number boundary layer depth [nondim] + real, allocatable, dimension(:,:) :: StokesXI !< Stokes similarity parameter [nondim] + real, allocatable, dimension(:,:) :: BEdE_ER !< Enrtainment Rule's Parameterized BEdE [ m3 s-3 ] + ! Other arrays + real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] + real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [Z ~> m] + real, pointer, dimension(:,:) :: PU_TKE !< Parameterized shear TKE Production [ m3 s-3 ] + real, pointer, dimension(:,:) :: PS_TKE !< Parameterized Stokes TKE Production [ m3 s-3 ] + real, pointer, dimension(:,:) :: PB_TKE !< Parameterized buoyancy TKE Production [ m3 s-3 ] end type KPP_CS @@ -518,9 +534,19 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) endif call get_param(paramFile, mdl, "KPP_CVt2", CS%KPP_CVt2, & - 'Parameter for Stokes MOST convection entrainment', & + 'Parameter for Stokes MOST convection entrainment (unresolved shear)', & units="nondim", default=1.6) + call get_param(paramFile, mdl, "KPP_ER_Cb", CS%KPP_ER_Cb, & + 'Entrainment Rule TKE buoyancy production weight', & + units="nondim", default=0.96) + call get_param(paramFile, mdl, "KPP_ER_Cs", CS%KPP_ER_Cs, & + 'Entrainment Rule TKE Stokes production weight', & + units="nondim", default=0.038) + call get_param(paramFile, mdl, "KPP_ER_Cu", CS%KPP_ER_Cu, & + 'Entrainment Rule TKE shear production weight', & + units="nondim", default=0.023) + call get_param(paramFile, mdl, "ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic in the CVMix KPP calculations. Values "//& "below 20240501 recover the answers from early in 2024, while higher values "//& @@ -537,6 +563,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) vonKarman=CS%vonKarman, & surf_layer_ext=CS%surf_layer_ext, & CVt2=CS%KPP_CVt2, & + ER_Cb=CS%KPP_ER_Cb, & + ER_Cs=CS%KPP_ER_Cs, & + ER_Cu=CS%KPP_ER_Cu, & interp_type=CS%interpType, & interp_type2=CS%interpType2, & lEkman=CS%computeEkman, & @@ -567,51 +596,39 @@ 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) - CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & - 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', & - 'm2/s2', conversion=US%L_T_to_m_s**2) CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & 'Bulk Richardson number used to find the OBL depth used by [CVMix] KPP', 'nondim') - CS%id_Sigma = register_diag_field('ocean_model', 'KPP_sigma', diag%axesTi, Time, & - 'Sigma coordinate used by [CVMix] KPP', 'nondim') - CS%id_Ws = register_diag_field('ocean_model', 'KPP_Ws', diag%axesTL, Time, & - 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', & - 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_N = register_diag_field('ocean_model', 'KPP_N', diag%axesTi, Time, & '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s', conversion=US%s_to_T) CS%id_N2 = register_diag_field('ocean_model', 'KPP_N2', diag%axesTi, Time, & 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2', conversion=US%s_to_T**2) + CS%id_Ws = register_diag_field('ocean_model', 'KPP_Ws', diag%axesTL, Time, & + 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', & + 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_Vt2 = register_diag_field('ocean_model', 'KPP_Vt2', diag%axesTL, Time, & 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2', conversion=US%Z_to_m**2*US%s_to_T**2) + CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & + 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', & + 'm2/s2', conversion=US%L_T_to_m_s**2) + 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) CS%id_uStar = register_diag_field('ocean_model', 'KPP_uStar', diag%axesT1, Time, & 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_buoyFlux = register_diag_field('ocean_model', 'KPP_buoyFlux', diag%axesTi, Time, & 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', & 'm2/s3', conversion=US%L_to_m**2*US%s_to_T**3) + CS%id_Sigma = register_diag_field('ocean_model', 'KPP_sigma', diag%axesTi, Time, & + 'Sigma coordinate used by [CVMix] KPP', 'nondim') + CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & + 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kt_KPP = register_diag_field('ocean_model', 'KPP_Kheat', diag%axesTi, Time, & 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) - CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & - 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) - CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & - 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', & - 'm2/s', conversion=US%Z2_T_to_m2_s) - CS%id_NLTt = register_diag_field('ocean_model', 'KPP_NLtransport_heat', diag%axesTi, Time, & - 'Non-local transport (Cs*G(sigma)) for heat, as calculated by [CVMix] KPP', 'nondim') - CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & - 'Non-local tranpsort (Cs*G(sigma)) for scalars, as calculated by [CVMix] KPP', 'nondim') CS%id_Tsurf = register_diag_field('ocean_model', 'KPP_Tsurf', diag%axesT1, Time, & 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & 'C', conversion=US%C_to_degC) @@ -624,6 +641,12 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & 'm/s', conversion=US%L_T_to_m_s) + CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & + 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) + CS%id_NLTt = register_diag_field('ocean_model', 'KPP_NLtransport_heat', diag%axesTi, Time, & + 'Non-local transport (Cs*G(sigma)) for heat, as calculated by [CVMix] KPP', 'nondim') + CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & + 'Non-local tranpsort (Cs*G(sigma)) for scalars, as calculated by [CVMix] KPP', 'nondim') CS%id_EnhK = register_diag_field('ocean_model', 'EnhK', diag%axesTI, Time, & 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & @@ -631,30 +654,57 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) CS%id_La_SL = register_diag_field('ocean_model', 'KPP_La_SL', diag%axesT1, Time, & 'Surface-layer Langmuir number computed in [CVMix] KPP','nondim') + ! only available when StokesMOST is enabled + if (CS%StokesMOST) then + CS%id_ERdepth = register_diag_field('ocean_model', 'ERdepth', diag%axesT1, Time, & + 'Entrainment Rule Boundary Layer depth percent', 'nondim') + CS%id_RNdepth = register_diag_field('ocean_model', 'RNdepth', diag%axesT1, Time, & + 'Richardson Number Boundary Layer depth percent', 'nondim') + 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') + CS%id_BEdE_ER = register_diag_field('ocean_model', 'BEdE_ER', diag%axesT1, Time, & + 'Entrainment Rule BEdE_ER', 'm3 s-3', conversion=US%L_T_to_m_s**3) + CS%id_PU_TKE = register_diag_field('ocean_model', 'PU_TKE' , diag%axesT1, Time, & + 'Shear production of surface layer TKE', 'm3 s-3') + CS%id_PS_TKE = register_diag_field('ocean_model', 'PS_TKE' , diag%axesT1, Time, & + 'Stokes production of surface layer TKE', 'm3 s-3') + CS%id_PB_TKE = register_diag_field('ocean_model', 'PB_TKE' , diag%axesT1, Time, & + 'Buoyancy production of surface layer TKE', 'm3 s-3') + ! arrays only needed when StokesMOST is enabled + allocate( CS%Lam2 ( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%PU_TKE( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%PS_TKE( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%PB_TKE( SZI_(G), SZJ_(G) ), source=0. ) + endif + allocate( CS%N( SZI_(G), SZJ_(G), SZK_(GV)+1 ), 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%StokesXI( 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. ) - if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) - + allocate( CS%kOBL( SZI_(G), SZJ_(G) ), source=0. ) allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ), source=0.0 ) - if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) - if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + allocate( CS%ERdepth( SZI_(G), SZJ_(G) ), source=0. ) + allocate( CS%RNdepth( SZI_(G), SZJ_(G) ), source=0. ) + if (CS%id_BulkRi > 0) allocate( CS%BulkRi( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) - if (CS%id_Sigma > 0) allocate( CS%sigma( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) - if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) if (CS%id_N2 > 0) allocate( CS%N2( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Ws > 0) allocate( CS%Ws( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_BulkUz2 > 0) allocate( CS%Uz2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) + if (CS%id_Sigma > 0) allocate( CS%sigma( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_Kv_KPP > 0) allocate( CS%Kv_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) if (CS%id_Kt_KPP > 0) allocate( CS%Kt_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) if (CS%id_Ks_KPP > 0) allocate( CS%Ks_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) - if (CS%id_Kv_KPP > 0) allocate( CS%Kv_KPP( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) if (CS%id_Tsurf > 0) allocate( CS%Tsurf( SZI_(G), SZJ_(G) ), source=0. ) if (CS%id_Ssurf > 0) allocate( CS%Ssurf( SZI_(G), SZJ_(G) ), source=0. ) if (CS%id_Usurf > 0) allocate( CS%Usurf( SZIB_(G), SZJ_(G) ), source=0. ) if (CS%id_Vsurf > 0) allocate( CS%Vsurf( SZI_(G), SZJB_(G) ), source=0. ) if (CS%id_EnhVt2 > 0) allocate( CS%EnhVt2( SZI_(G), SZJ_(G), SZK_(GV) ), source=0. ) if (CS%id_EnhK > 0) allocate( CS%EnhK( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=0. ) + if (CS%id_OBLdepth_original > 0) allocate( CS%OBLdepth_original( SZI_(G), SZJ_(G) ) ) + if (CS%id_BEdE_ER > 0) allocate( CS%BEdE_ER( SZI_(G), SZJ_(G) ), source=0. ) id_clock_KPP_calc = cpu_clock_id('Ocean KPP calculate)', grain=CLOCK_MODULE) id_clock_KPP_compute_BLD = cpu_clock_id('(Ocean KPP comp BLD)', grain=CLOCK_ROUTINE) @@ -854,7 +904,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 + StokesXi = CS%StokesXI(i,j), & ! Stokes forcing parameter CVMix_kpp_params_user=CS%KPP_params ) ! safety check, Kviscosity and Kdiffusivity must be >= 0 @@ -1027,6 +1077,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension( GV%ke+1 ) :: N_col ! A column of buoyancy frequencies at interfaces in MKS units [s-1] real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: surfBuoy_NS ! Non-solar surface buoyancy flux in MKS units [m2 s-3] + real :: etaDk ! Approximate solar decay from surfBuoyFlux2 (2) and (3) [m-1] real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] @@ -1068,18 +1120,22 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: surfHuS, surfHvS ! Stokes drift velocities integrated over the boundary layer [Z L T-1 ~> m2 s-1] real :: surfUs, surfVs ! Stokes drift velocities averaged over the boundary layer [Z T-1 ~> m s-1] - integer :: i, j, k, km1, kk, ksfc, ktmp ! Loop indices - + 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 :: uS_SL, vS_SL ! Stokes at Surface Layer Depth [L T-1 ~> m s-1] + real :: uSb_SL, vSb_SL ! Average Stokes to Surface Layer Depths [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 + real :: BEdE_ER ! Entrainment Rule [ m3 s-3 ] + real :: PU_TKE, PS_TKE, PB_TKE ! Shear, Stokes, Buoyancy TKE production rate [ m3 s-3 ] + real, dimension( GV%ke ) :: StokesXI_1d ! Parameters of TKE production ratio [nondim] + real, dimension( GV%ke ) :: BEdE_ER_1d ! Entrainment Rule parameterized [Z^3 T-3 ~> m s-1] + real :: ERdepth ! Entrainment Rule Boundary layer depth CVMix_kpp_compute_ER_depth in MKS units [m] + real :: check ! Entrainment Rule Boundary layer depth CVMix_kpp_compute_ER_depth in MKS units [m] + real :: Llimit ! Stable boundary Layer Limit = vonk Lstar [Z ~> m] + integer :: kbl ! index of cell containing boundary layer depth [nondim] 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.") @@ -1096,9 +1152,9 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! some constants GoRho = US%Z_to_m*US%s_to_T**2 * (GV%g_Earth_Z_T2 / GV%Rho0) if (GV%Boussinesq) then - GoRho_Z_L2 = GV%Z_to_H * GV%g_Earth_Z_T2 / GV%Rho0 + GoRho_Z_L2 = US%L_to_Z**2 * GV%Z_to_H * GV%g_Earth / GV%Rho0 else - GoRho_Z_L2 = GV%g_Earth_Z_T2 * GV%RZ_to_H + GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth * GV%RZ_to_H endif buoy_scale = US%L_to_m**2*US%s_to_T**3 @@ -1114,28 +1170,44 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$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, 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 uS_H, vS_H, uSbar_H, vSbar_H , uS_Hi, vS_Hi, uSb_SL, vSb_SL, & + !$OMP uS_SL, vS_SL, StokesXI, StokesXI_1d, surfBuoy_NS, etadk, & + !$OMP BEdE_ER_1d, ERdepth, BEdE_ER, PU_TKE, PS_TKE, PB_TKE, 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, Vt_layer) + !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult, & + !$OMP Vt_layer) + do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then + iFaceHeight(:) = 0.0 ! BBL is always relative to the surface iFaceHeight(1) + 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)) 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 + ! Load surface Stokes uS_Hi(1), vS_Hi(1); 1.0 is a dummy number + call Compute_StokesDrift(i, j, 1.0, iFaceHeight(1), & + 0.5*h(i,j,1), iFaceHeight(1), -h(i,j,1), & ! zBL, zSLtop, zSL + uS_Hi(1), vS_Hi(1), uS_H(1), vS_H(1), uS_SL, vS_SL, & + uSbar_H(1), vSbar_H(1), uSb_SL, vSb_SL, waves) 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) + ! Estimate non-solar surface buoyancy flux + ! Ideally, this should be provided to this subroutine. However, right now only the + ! total surface flux (solar + non-solar) is provided. + surfBuoy_NS = 0.0 ! temporary surface solar + if ( (buoyFlux(i,j,3) > 0.0) .and. (buoyFlux(i,j,3) < buoyFlux(i,j,2)) ) then + etaDk = alog(buoyFlux(i,j,2)/buoyFlux(i,j,3)) / (dz(i,j,2) + GV%H_subroundoff) ! (z_inter(2)-z_inter(3)) + surfBuoy_NS = buoyFlux(i,j,2) * exp( -etaDk * dz(i,j,1) ) ! Approximate surface solar buoyancy flux + endif + surfBuoy_NS = buoyFlux(i,j,1) - surfBuoy_NS ! Total - solar = non-solar surface buoyancy flux ! Bulk Richardson number computed for each cell in a column, ! assuming OBLdepth = grid cell depth. After Rib(k) is @@ -1143,16 +1215,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! the actual OBLdepth. This approach avoids need to iterate ! on the OBLdepth calculation. It follows that used in MOM5 ! and POP. - 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. - 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 = 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 @@ -1175,22 +1243,29 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl surfBuoyFlux = buoy_scale * & (buoyFlux(i,j,1) - 0.5*(buoyFlux(i,j,max(2,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 ) + cellHeight(k),iFaceHeight(ksfc),-SLdepth_0d, & + uS_Hi(k+1), vS_Hi(k+1), uS_H(k), vS_H(k), uS_SL, vS_SL, & + uSbar_H(k), vSbar_H(k), uSb_SL, vSb_SL, waves) + uE_H(k) = U_H(k) - 0.5 * (Waves%US_x(I,j,k)+Waves%US_x(I-1,j,k)) + vE_H(k) = V_H(k) - 0.5 * (Waves%US_y(i,J,k)+Waves%US_y(i,J-1,k)) + + call cvmix_kpp_compute_StokesXi( iFaceHeight, CellHeight, ksfc ,SLdepth_0d, surfBuoyFlux, & + surfBuoy_NS,surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, vS_Hi, uSbar_H, vSbar_H, & + uS_SL, vS_SL, uSb_SL, vSb_SL, StokesXI, BEdE_ER, PU_TKE, PS_TKE, PB_TKE, & + CVMix_kpp_params_user=CS%KPP_params ) + + ! Save 1D Stokes XI similarity parameter and entrainment rule StokesXI_1d(k) = StokesXI - StokesVt_1d(k) = 0.0 ! StokesXI + BEdE_ER_1d(k) = BEdE_ER ! average temperature, salinity, u and v over surface layer starting at ksfc delH = SLdepth_0d + iFaceHeight(ksfc) 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 + surfHu = (uE_H(ksfc) + uSb_SL) * delH + surfHv = (vE_H(ksfc) + vSb_SL) * delH hTot = delH do ktmp = 1,ksfc-1 ! if ksfc >=2 delH = h(i,j,ktmp)*GV%H_to_Z @@ -1206,8 +1281,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl surfU = surfHu * I_hTot surfV = surfHv * I_hTot - Uk = uE_H(k) + uS_H(k) - surfU - Vk = vE_H(k) + vS_H(k) - surfV + Uk = u_H(k) - surfU + Vk = v_H(k) - surfV else !not StokesMOST StokesXI_1d(k) = 0.0 @@ -1221,13 +1296,10 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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 @@ -1239,24 +1311,18 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl endif enddo - !I_hTot = 1./hTot - !surfTemp = surfHtemp * I_hTot - !surfSalt = surfHsalt * I_hTot - !surfU = surfHu * I_hTot - !surfV = surfHv * I_hTot - !surfUs = surfHus * I_hTot - !surfVs = surfHvs * I_hTot - - surfTemp = surfHtemp / hTot - surfSalt = surfHsalt / hTot - surfU = surfHu / hTot - surfV = surfHv / hTot - surfUs = surfHus / hTot - surfVs = surfHvs / hTot + I_hTot = 1./hTot + surfTemp = surfHtemp * I_hTot + surfSalt = surfHsalt * I_hTot + surfU = surfHu * I_hTot + surfV = surfHv * I_hTot + surfUs = surfHus * I_hTot + surfVs = surfHvs * I_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 + 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 @@ -1296,14 +1362,13 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl enddo ! k-loop finishes - if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then + if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT)) then MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & dz=dz(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) CS%La_SL(i,j) = LA endif - ! compute in-situ density call calculate_density(Temp_1D, Salt_1D, pres_1D, rho_1D, tv%eqn_of_state) @@ -1317,7 +1382,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (GV%Boussinesq .or. GV%semi_Boussinesq) then deltaBuoy(k) = GoRho*(rho_1D(kk+2) - rho_1D(kk+1)) else - deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * GV%g_Earth_Z_T2 * & + deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * (US%L_to_Z**2 * GV%g_Earth) * & ( (rho_1D(kk+2) - rho_1D(kk+1)) / (0.5 * (rho_1D(kk+2) + rho_1D(kk+1))) ) endif N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & @@ -1337,45 +1402,73 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl z_inter(K) = US%Z_to_m*iFaceHeight(K) enddo - ! CVMix_kpp_compute_turbulent_scales_1d_OBL computes w_s velocity scale at cell centers for - ! CVmix_kpp_compute_bulk_Richardson call to CVmix_kpp_compute_unresolved_shear - ! at sigma=Vt_layer (CS%surf_layer_ext or 1.0) for this calculation. - ! StokesVt_1d controls Stokes enhancement (= 0 for none) - Vt_layer = 1.0 ! CS%surf_layer_ext - call CVMix_kpp_compute_turbulent_scales( & ! 1d_OBL + ! Use CS%deepOBLoffset (<-0.1*iFaceHeight(GV%ke+1)) to avoid vanishingly small layers near the bottom. + zBottomMinusOffset = iFaceHeight(GV%ke) + min( max(CS%deepOBLoffset,0.0), -0.1*iFaceHeight(GV%ke+1)) + + ! use these to check if all points are convered + CS%ERdepth(i,j) = 0.0 + CS%RNdepth(i,j) = 0.0 + + if (CS%fixedOBLdepth) then + CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer + else + ERdepth = 0.0 + if ( CS%StokesMOST .and. (surfBuoy_NS < 0.0) ) then + ! Search for Entrainment rule depth (ER_depth) + call CVMix_kpp_compute_ER_depth( & + z_inter, & ! (in) Interface heights <= 0 [m] + N2_1d, & ! (in) Column of Buoyancy Gradients at interfaces + OBL_depth, & ! (in) Array of assumed OBL depths [m] + surfFricVel, & ! (in) surface friction velocity [m s-1] + surfBuoy_NS, & ! (in) surface non-solar Buoyancy flux + surfBuoyFlux2, & ! (in) Buoyancy flux surface to OBL_depth + StokesXI_1d, & ! (in) Stokes similarity parameter given OBL_depth + BEdE_ER_1d, & ! (in) Parameterized Entrainment Rule given OBL_depth + ERdepth, & ! (out) Entrainment Rule Boundary Layer Depth + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + + if ( ERdepth > -iFaceHeight(2) ) then ! deeper than top layer + CS%OBLdepth(i,j) = US%m_to_Z * ERdepth ! min( ERdepth , -zBottomMinusOffset ) + CS%ERdepth(i,j) = 100. ! check and diagnostic for ER depth calculated + endif + endif + + ! Original Richardson Number method (always the case with CS%StokesMOST=False) + if (CS%ERdepth(i,j) == 0.) then + Vt_layer = 1.0 ! CS%surf_layer_ext + call CVMix_kpp_compute_turbulent_scales( & ! 1d_OBL Vt_layer, & ! (in) Boundary layer extent contributing to unresolved shear 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 + xi=StokesXi_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 ) - ! Determine the enhancement factor for unresolved shear - IF (CS%LT_VT2_ENHANCEMENT) then - IF (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then - LangEnhVT2 = CS%KPP_VT2_ENH_FAC - elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then - !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. - if (present(lamult)) then - LangEnhVT2 = lamult(i,j) + ! Determine the enhancement factor for unresolved shear + if (CS%LT_VT2_ENHANCEMENT) then + if (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then + LangEnhVT2 = CS%KPP_VT2_ENH_FAC + elseif (CS%LT_VT2_METHOD==LT_VT2_MODE_VR12) then + !Introduced minimum value for La_SL, so maximum value for enhvt2 is removed. + if (present(lamult)) then + LangEnhVT2 = lamult(i,j) + else + LangEnhVT2 = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & + (5.4*CS%La_SL(i,j))**(-4)) + endif + else + ! for other methods (e.g., LT_VT2_MODE_RW16, LT_VT2_MODE_LF17), the enhancement factor is + ! computed internally within CVMix using LaSL, bfsfc, and ustar to be passed to CVMix. + LangEnhVT2 = 1.0 + endif else - LangEnhVT2 = sqrt(1.+(1.5*CS%La_SL(i,j))**(-2) + & - (5.4*CS%La_SL(i,j))**(-4)) + LangEnhVT2 = 1.0 endif - else - ! for other methods (e.g., LT_VT2_MODE_RW16, LT_VT2_MODE_LF17), the enhancement factor is - ! computed internally within CVMix using LaSL, bfsfc, and ustar to be passed to CVMix. - LangEnhVT2 = 1.0 - endif - else - LangEnhVT2 = 1.0 - endif - - surfBuoyFlux = buoy_scale * buoyFlux(i,j,1) - ! Calculate Bulk Richardson number from eq (21) of LMD94 - BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & + ! Calculate Bulk Richardson number from eq (21) of LMD94 + BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & zt_cntr=z_cell, & ! Depth of cell center [m] delta_buoy_cntr=deltaBuoy, & ! Bulk buoyancy difference, Br-B(z) [m s-2] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] @@ -1387,86 +1480,65 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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 - z_inter, & ! (in) Height of interfaces [m] - KPP_OBL_depth, & ! (out) OBL depth [m] - 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=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 + + call CVMix_kpp_compute_OBL_depth( & + BulkRi_1d, & ! (in) Bulk Richardson number + z_inter, & ! (in) Height of interfaces [m] + KPP_OBL_depth, & ! (out) OBL depth [m] + 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=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 + CS%RNdepth(i,j) = 100. ! check and diagnostic + endif ! KPP_OBL_depth + + endif ! fixedOBLdepth + CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) ! no deeper than deepOBLoffset off bottom + CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) kbl = int(CS%kOBL(i,j)) - SLdepth_0d = CS%surf_layer_ext*CS%OBLdepth(i,j) - surfBuoyFlux = surfBuoyFlux2(kbl) + + if (CS%StokesMOST) then + ! Now we have OBLdepth and need to compute diagnostics + 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 + 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 - 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 + call Compute_StokesDrift(i,j, iFaceHeight(kbl), iFaceHeight(kbl+1), & + -CS%OBLdepth(i,j),iFaceHeight(ksfc),-SLdepth_0d, & + uS_Hi(kbl+1), vS_Hi(kbl+1), uS_H(kbl), vS_H(kbl), uS_SL, vS_SL, & + uSbar_H(kbl), vSbar_H(kbl), uSb_SL, vSb_SL, waves) - ! apply some constraints on OBLdepth - if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value - CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer - 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) ) + call cvmix_kpp_compute_StokesXi(iFaceHeight, CellHeight, ksfc ,SLdepth_0d, surfBuoyFlux, & + surfBuoy_NS,surfFricVel,waves%omega_w2x(i,j), uE_H, vE_H, uS_Hi, vS_Hi, & + uSbar_H, vSbar_H, uS_SL, vS_SL, uSb_SL, vSb_SL, & + StokesXI,BEdE_ER,PU_TKE,PS_TKE,PB_TKE,CVMix_kpp_params_user=CS%KPP_params ) - endif !Stokes_MOST + CS%Lam2(i,j) = sqrt(US_Hi(1)**2+VS_Hi(1)**2) / surfFricVel + CS%PU_TKE(i,j) = PU_TKE + CS%PS_TKE(i,j) = PS_TKE + CS%PB_TKE(i,j) = PB_TKE + CS%StokesXI(i,j) = StokesXI ! StokesXI_1d(kbl) - ! compute unresolved squared velocity for diagnostics - if (CS%id_Vt2 > 0) then - Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & - z_cell, & ! Depth of cell center [m] - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] - 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=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**2*US%T_to_s**2 * Vt2_1d(:) endif - ! recompute wscale for diagnostics, now that we in fact know boundary layer depth + ! recompute unresolved squared velocity, wscale and BulkRi for known boundary layer depth + ! compute unresolved squared velocity for diagnostics + ! recompute wscale for diagnostics, !BGR consider if LTEnhancement is wanted for diagnostics - if (CS%id_Ws > 0) then + if ( (CS%id_Ws > 0) .or. (CS%id_Vt2 > 0) .or. (CS%id_BulkRi > 0) ) then call CVMix_kpp_compute_turbulent_scales( & -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate [nondim] US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] @@ -1475,26 +1547,51 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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(:) + if ( CS%id_Ws > 0 ) CS%Ws(i,j,:) = US%m_to_Z*US%T_to_s*Ws_1d(:) + endif + + if ( (CS%id_Vt2 > 0) .or. (CS%id_BulkRi > 0) ) then + Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & + z_cell, & ! Depth of cell center [m] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] + 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=surfBuoyFlux2, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] + CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + if (CS%id_Vt2 > 0) CS%Vt2(i,j,:) = US%m_to_Z**2 * US%T_to_s**2 * Vt2_1d(:) + endif + if (CS%id_BulkRi > 0) then + do k = 1, GV%ke + BulkRi_1d(k) = -z_cell(k) * deltaBuoy(kbl) / ( deltaU2(k) + Vt2_1d(k) ) + CS%BulkRi(i,j,k) = BulkRi_1d(k) + enddo endif - ! Diagnostics + ! Diagnostics if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) - if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = US%m_s_to_L_T**2 * deltaU2(:) if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV + if (CS%id_BEdE_ER > 0) CS%BEdE_ER(i,j) = BEdE_ER endif ; enddo enddo call cpu_clock_end(id_clock_KPP_compute_BLD) + if (CS%debug .and. CS%StokesMOST) then + call hchksum(CS%PS_TKE, 'MOM_CVMix_KPP: PS_TKE', G%HI) + call hchksum(CS%PU_TKE, 'MOM_CVMix_KPP: PU_TKE', G%HI) + call hchksum(CS%PB_TKE, 'MOM_CVMix_KPP: PB_TKE', G%HI) + endif + ! send diagnostics to post_data - if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) + if (CS%id_BulkRi > 0) call post_data(CS%id_BulkRi, CS%BulkRi, CS%diag) if (CS%id_N > 0) call post_data(CS%id_N, CS%N, CS%diag) if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) if (CS%id_Tsurf > 0) call post_data(CS%id_Tsurf, CS%Tsurf, CS%diag) @@ -1509,8 +1606,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl 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) + if (CS%id_StokesXI > 0) call post_data(CS%id_StokesXI, CS%StokesXI, CS%diag) + if (CS%id_Lam2 > 0) call post_data(CS%id_Lam2 , CS%Lam2, CS%diag) + if (CS%id_BEdE_ER > 0) call post_data(CS%id_BEdE_ER, CS%BEdE_ER, CS%diag) + if (CS%id_ERdepth > 0) call post_data(CS%id_ERdepth, CS%ERdepth, CS%diag) + if (CS%id_RNdepth > 0) call post_data(CS%id_RNdepth, CS%RNdepth, CS%diag) + if (CS%id_PU_TKE > 0) call post_data(CS%id_PU_TKE, CS%PU_TKE, CS%diag) + if (CS%id_PS_TKE > 0) call post_data(CS%id_PS_TKE, CS%PS_TKE, CS%diag) + if (CS%id_PB_TKE > 0) call post_data(CS%id_PB_TKE, CS%PB_TKE, CS%diag) endif ! BLD smoothing: @@ -1635,7 +1738,6 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, dz) 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 @@ -1658,6 +1760,24 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) end subroutine KPP_get_BLD +!> Copies CS%Lam2 into Lam2. +subroutine KPP_get_Lam2(CS, Lam2, G, US) + type(KPP_CS), pointer :: CS !< Control structure for + !! this module + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Lam2 !< (Langmuir Number)^-2 [nondim] + + ! Local variables + integer :: i,j ! Horizontal indices + + !$OMP parallel do default(none) shared(Lam2, CS, G) + do j = G%jsc, G%jec ; do i = G%isc, G%iec + Lam2(i,j) = CS%Lam2(i,j) + enddo ; enddo + +end subroutine KPP_get_Lam2 + !> Apply KPP non-local transport of surface fluxes for a given tracer subroutine KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, & dt, diag, tr_ptr, scalar, flux_scale) @@ -1765,47 +1885,75 @@ 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 + +!> Compute Stokes Drift components and integrals needed to compute +!! Stokes TKE production parameters. +subroutine Compute_StokesDrift(i ,j, ztop, zbot, zBL, zSLtop, zSL, uS_i, vS_i, uS_k, vS_k, uS_SL, vS_SL, & + uSbar, vSbar, uSb_SL, vSb_SL, waves) + type(wave_parameters_CS), pointer :: waves !< Wave CS for Langmuir turbulence + real, intent(in) :: ztop !< boundary layer cellheight top (<0) [m] + real, intent(in) :: zbot !< boundary layer cellheight bottom (<0) [m] + real, intent(in) :: zBL !< boundary layer cellheight center (<0) [m] + real, intent(in) :: zSLtop !< surface layer cell top [m] + real, intent(in) :: zSL !< surface layer cell depth [m] + real, intent(inout) :: uS_i !< Zonal Stokes velocity at zbot interface [m s-1] + real, intent(inout) :: vS_i !< Meridional Stokes velocity at zbot interface [m s-1] + real, intent(inout) :: uS_k !< Zonal Stokes velocity at zbl [m s-1] + real, intent(inout) :: vS_k !< Meridional Stokes velocity at zbl [m s-1] + real, intent(inout) :: uS_SL !< Zonal Stokes velocity at zSL [m s-1] + real, intent(inout) :: vS_SL !< Meridional Stokes velocity at zSL [m s-1] + real, intent(inout) :: uSbar !< Mean zonal Stokes velocity at ztop [m s-1] + real, intent(inout) :: vSbar !< Mean meridional Stokes velocity at zbot [m s-1] + real, intent(inout) :: uSb_SL !< Mean zonal Stokes velocity at zSLtop [m s-1] + real, intent(inout) :: vSb_SL !< Mean meridional Stokes velocity at zSL [m s-1] + integer, intent(in) :: i !< Meridional index of H-point [nondim] + integer, intent(in) :: j !< Zonal index of H-point [nondim] ! local variables integer :: b !< wavenumber band index - real :: fexp !< an exponential function + real :: fexp !< dummy 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 + ! initialize variables + uS_i = 0.0 + vS_i = 0.0 + uS_k = 0.0 + vS_k = 0.0 + uS_SL = 0.0 + vS_SL = 0.0 + uSbar = 0.0 + vSbar = 0.0 + uSb_SL = 0.0 + vSb_SL = 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) ) + + fexp = exp(2. * WaveNum * zBL ) 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) + + fexp = exp(2. * WaveNum * zSL ) + uS_SL = uS_SL + waves%Ustk_Hb(i,j,b) * fexp + vS_SL = vS_SL + 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 + + fexp = exp(2. * WaveNum * zSLtop) - exp(2. * WaveNum * zSL) + uSb_SL = uSb_SL + 0.5 * waves%Ustk_Hb(i,j,b) * fexp / WaveNum + vSb_SL = vSb_SL + 0.5 * waves%Vstk_Hb(i,j,b) * fexp / WaveNum + enddo - uSbar = uSbar / (ztop-zbot) - vSbar = vSbar / (ztop-zbot) + uSbar = uSbar / (ztop-zbot) + vSbar = vSbar / (ztop-zbot) + uSb_SL = uSb_SL / (zSLtop-zSL) + vSb_SL = vSb_SL / (zSLtop-zSL) end subroutine Compute_StokesDrift @@ -1816,7 +1964,6 @@ subroutine KPP_end(CS) if (.not.associated(CS)) return deallocate(CS) - end subroutine KPP_end end module MOM_CVMix_KPP diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 3589c184df..759c470d39 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -176,7 +176,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) integer :: kOBL !< level of ocean boundary layer extent real :: g_o_rho0 ! Gravitational acceleration, perhaps divided by density, times unit conversion factors ! [H s-2 R-1 ~> m4 s-2 kg-1 or m s-2] - real :: pref ! Interface pressures [R L2 T-2 ~> Pa] + real :: pRef ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] real :: dh_int ! The distance between layer centers [H ~> m or kg m-2] real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] @@ -213,7 +213,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) do K=2,GV%ke ! pRef is pressure at interface between k and km1 [R L2 T-2 ~> Pa]. - pRef = pRef + (GV%H_to_RZ*GV%g_Earth) * h(i,j,k) + pRef = pRef + (GV%H_to_RZ*GV%g_Earth) * h(i,j,k-1) call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state) call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 1d43b95447..d4d9f031d9 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -37,6 +37,8 @@ module MOM_CVMix_shear integer :: n_smooth_ri !< Number of times to smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number [nondim] real :: Nu_zero !< LMD94 maximum interior diffusivity [Z2 T-1 ~> m2 s-1] + real :: Prandtl !< The turbulent Prandtl number to be used in the + !! CVMIX shear mixing [nondim] real :: KPP_exp !< Exponent of unitless factor of diffusivities !! for KPP internal shear mixing scheme [nondim] real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] @@ -291,6 +293,9 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "NOTE this the internal mixing and this is "// & "not for setting the boundary layer depth.", & units="nondim", default=0.8) + call get_param(param_file, mdl, "PRANDTL_CVMIX_SHEAR", CS%Prandtl, & + "The turbulent Prandtl number to be used in the "// & + "CVMIX shear mixing.", units="nondim", default=1.0) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & "Exponent of unitless factor of diffusivities, "// & "for KPP internal shear mixing scheme.", & @@ -302,7 +307,8 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & KPP_nu_zero=US%Z2_T_to_m2_s*CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & - KPP_exp=CS%KPP_exp) + KPP_exp=CS%KPP_exp, & + Prandtl_shear=CS%Prandtl) ! Register diagnostics; allocation and initialization CS%diag => diag diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5389de3e1d..33cb72e83b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -55,7 +55,7 @@ module MOM_diabatic_driver use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate -use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD, register_KPP_restarts +use MOM_CVMix_KPP, only : KPP_end, KPP_get_BLD, register_KPP_restarts, KPP_get_Lam2 use MOM_CVMix_KPP, only : KPP_NonLocalTransport_temp, KPP_NonLocalTransport_saln use MOM_oda_incupd, only : apply_oda_incupd, oda_incupd_CS use MOM_opacity, only : opacity_init, opacity_end, opacity_CS @@ -69,7 +69,7 @@ module MOM_diabatic_driver use MOM_sponge, only : apply_sponge, sponge_CS use MOM_ALE_sponge, only : apply_ALE_sponge, ALE_sponge_CS use MOM_time_manager, only : time_type, real_to_time, operator(-), operator(<=) -use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS +use MOM_tracer_flow_control, only : call_tracer_column_fns, tracer_flow_control_CS, extract_tracer_flow_member use MOM_tracer_diabatic, only : tracer_vertdiff, tracer_vertdiff_Eulerian use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, accel_diag_ptrs @@ -188,6 +188,10 @@ module MOM_diabatic_driver logical :: Use_KdWork_diag = .false. !< Logical flag to indicate if any Kd_work diagnostics are on. logical :: Use_N2_diag = .false. !< Logical flag to indicate if any N2 diagnostics are on. + ! MARBL needs T & S from before the tracer_vertdiff call + real, allocatable, dimension(:,:,:) :: prediabatic_T !< Temperature prior to calling diabatic driver [C ~> degC] + real, allocatable, dimension(:,:,:) :: prediabatic_S !< Salinity prior to calling diabatic driver [S ~> ppt] + !>@{ Diagnostic IDs integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 @@ -589,6 +593,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + Lam2, & ! (Langmuir Number)^-2 [nondim] KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL @@ -649,6 +654,22 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("diabatic_ALE_legacy(), MOM_diabatic_driver.F90") + ! Some tracer packages require T & S from the beginning of the diabatic step to + ! provide forcing consistent with the passive tracer values. The initialization + ! routine will allocate prediabatic_T and prediabatic_S if the tracer flow control + ! structure indicates it is necessary. If these arrays are allocated, they will store + ! a copy of tv%T & tv%S before this subroutine modifies the tv structure. + if (allocated(CS%prediabatic_T)) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%prediabatic_T(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + if (allocated(CS%prediabatic_S)) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%prediabatic_S(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep call enable_averages(dt, Time_end, CS%diag) @@ -766,10 +787,14 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim endif call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + if (associated(visc%Lam2)) then + call KPP_get_Lam2(CS%KPP_CSp, Lam2(:,:), G, US) + endif ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) + if (associated(visc%Lam2)) visc%Lam2(:,:) = Lam2(:,:) if (.not.CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -1204,7 +1229,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML, & + prediabatic_T=CS%prediabatic_T, prediabatic_S=CS%prediabatic_S) call cpu_clock_end(id_clock_tracers) @@ -1302,6 +1328,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(SZI_(G),SZJ_(G)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + Lam2, & ! (Langmuir Number)^-2 [nondim] KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] SkinBuoyFlux, & ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL @@ -1365,6 +1392,22 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, if (.not. (CS%useALEalgorithm)) call MOM_error(FATAL, "MOM_diabatic_driver: "// & "The ALE algorithm must be enabled when using MOM_diabatic_driver.") + ! Some tracer packages require T & S from the beginning of the diabatic step to + ! provide forcing consistent with the passive tracer values. The initialization + ! routine will allocate prediabatic_T and prediabatic_S if the tracer flow control + ! structure indicates it is necessary. If these arrays are allocated, they will store + ! a copy of tv%T & tv%S before this subroutine modifies the tv structure. + if (allocated(CS%prediabatic_T)) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%prediabatic_T(i,j,k) = tv%T(i,j,k) + enddo ; enddo ; enddo + endif + if (allocated(CS%prediabatic_S)) then + do k=1,nz ; do j=js,je ; do i=is,ie + CS%prediabatic_S(i,j,k) = tv%S(i,j,k) + enddo ; enddo ; enddo + endif + ! For all other diabatic subroutines, the averaging window should be the entire diabatic timestep call enable_averages(dt, Time_end, CS%diag) @@ -1482,11 +1525,16 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + if (associated(visc%Lam2)) then + call KPP_get_Lam2(CS%KPP_CSp, Lam2(:,:), G, US) + endif ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) - if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) * US%L_to_Z**2 + if (associated(visc%Lam2)) visc%Lam2(:,:) = Lam2(:,:) if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") if (CS%debug) then @@ -1831,7 +1879,8 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML, & + prediabatic_T=CS%prediabatic_T, prediabatic_S=CS%prediabatic_S) call cpu_clock_end(id_clock_tracers) @@ -3236,7 +3285,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] - logical :: use_temperature + logical :: use_temperature, use_MARBL_tracers character(len=20) :: EN1, EN2, EN3 ! This "include" declares and sets the variable "version". @@ -3255,7 +3304,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%diag => diag CS%Time => Time - if (associated(tracer_flow_CSp)) CS%tracer_flow_CSp => tracer_flow_CSp + if (associated(tracer_flow_CSp)) then + CS%tracer_flow_CSp => tracer_flow_CSp + call extract_tracer_flow_member(tracer_flow_CSp, use_MARBL_tracers=use_MARBL_tracers) + if (use_MARBL_tracers) & + allocate(CS%prediabatic_T(SZI_(G),SZJ_(G), SZK_(G)), CS%prediabatic_S(SZI_(G),SZJ_(G), SZK_(G))) + end if if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp @@ -3877,6 +3931,9 @@ subroutine diabatic_driver_end(CS) deallocate(CS%optics) endif + if (allocated(CS%prediabatic_T)) deallocate(CS%prediabatic_T) + if (allocated(CS%prediabatic_S)) deallocate(CS%prediabatic_S) + if (CS%debug_energy_req) & call diapyc_energy_req_end(CS%diapyc_en_rec_CSp) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 0c72f83b0c..2bfada3bf1 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2714,7 +2714,7 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL, use_ideal_age - logical :: do_brine_plume, use_hor_bnd_diff, use_neutral_diffusion, use_fpmix + logical :: do_brine_plume, use_hor_bnd_diff, use_neutral_diffusion, use_fpmix, use_StokesMOST logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv integer :: isd, ied, jsd, jed, nz real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. @@ -2797,6 +2797,10 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C default=.false., do_not_log=.true.) call get_param(param_file, mdl, "FPMIX", use_fpmix, & default=.false., do_not_log=.true.) + call openParameterBlock(param_file, 'KPP', do_not_log=.true.) + call get_param(param_file, mdl, 'STOKES_MOST', use_StokesMOST, & + default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", use_ideal_age, & default=.false., do_not_log=.true.) call openParameterBlock(param_file, 'MLE', do_not_log=.true.) @@ -2807,17 +2811,24 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) endif + if (use_StokesMOST .and. MLE_use_Bodner) then + call safe_alloc_ptr(visc%Lam2, isd, ied, jsd, jed) + endif if ((hfreeze >= 0.0) .or. MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & use_neutral_diffusion .or. use_hor_bnd_diff .or. use_ideal_age) then call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) endif - if (MLE_use_PBL_MLD) then + if (MLE_use_PBL_MLD .or. MLE_use_Bodner) then call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) endif + if (use_StokesMOST .and. MLE_use_Bodner) then + call register_restart_field(visc%Lam2, "Lam2", .false., restart_CS, & + "(Langmuir Number)^-2", units="" ) + endif if (MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & - use_neutral_diffusion .or. use_hor_bnd_diff) then + use_neutral_diffusion .or. use_hor_bnd_diff .or. MLE_use_Bodner) then call register_restart_field(visc%h_ML, "h_ML", .false., restart_CS, & "Instantaneous active mixing layer thickness", & units=get_thickness_units(GV), conversion=GV%H_to_mks) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 3c324c4147..30c3d12e63 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -259,6 +259,13 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G pi = 4. * atan2(1.,1.) Irho0 = 1.0 / GV%Rho0 + ! initialize arrays + uE_h(:,:,:) = 0.0 + vE_h(:,:,:) = 0.0 + uE_u(:,:,:) = 0.0 + vE_v(:,:,:) = 0.0 + vInc_v(:,:,:) = 0.0 + uInc_u(:,:,:) = 0.0 call pass_var(hbl_h , G%Domain, halo=1) ! u-points @@ -352,20 +359,20 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, lpost, Cemp_NL, G 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 + Omega_tau2w(i,j,:) = 0.0 + Omega_tau2s(i,j,:) = 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 ) + 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_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 > 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 diff --git a/src/tracer/MARBL_forcing_mod.F90 b/src/tracer/MARBL_forcing_mod.F90 index 4713f91d44..1c80c5787f 100644 --- a/src/tracer/MARBL_forcing_mod.F90 +++ b/src/tracer/MARBL_forcing_mod.F90 @@ -10,7 +10,7 @@ module MARBL_forcing_mod !! 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_diag_mediator, only : safe_alloc_ptr, diag_ctrl 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 @@ -28,28 +28,15 @@ module MARBL_forcing_mod 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 ; private 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 [1] - real :: dust_ratio_to_fe_bioavail_frac !< ratio of dust to iron bioavailability fraction [1] real :: fe_bioavail_frac_offset !< offset for iron bioavailability fraction [1] real :: atm_fe_to_bc_ratio !< atmospheric iron to black carbon ratio [1] - real :: atm_bc_fe_bioavail_frac !< atmospheric black carbon to iron bioavailablity fraction ratio [1] real :: seaice_fe_to_bc_ratio !< sea-ice iron to black carbon ratio [1] - real :: seaice_bc_fe_bioavail_frac !< sea-ice black carbon to iron bioavailablity fraction ratio [1] real :: iron_frac_in_atm_fine_dust !< Fraction of fine dust from the atmosphere that is iron [1] real :: iron_frac_in_atm_coarse_dust !< Fraction of coarse dust from the atmosphere that is iron [1] real :: iron_frac_in_seaice_dust !< Fraction of dust from the sea ice that is iron [1] @@ -57,9 +44,7 @@ module MARBL_forcing_mod 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 + 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 @@ -73,14 +58,14 @@ module MARBL_forcing_mod contains - subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_marbl, CS) + subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_MARBL_tracers, 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? + logical, intent(in) :: use_MARBL_tracers !< 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 @@ -96,26 +81,18 @@ subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_marbl, allocate(CS) CS%diag => diag - CS%use_marbl_tracers = .true. - if (.not. use_marbl) then - CS%use_marbl_tracers = .false. + CS%use_MARBL_tracers = .true. + if (.not. use_MARBL_tracers) then + CS%use_MARBL_tracers = .false. return endif call get_param(param_file, mdl, "DUST_RATIO_THRES", CS%dust_ratio_thres, & - "coarse/fine dust ratio threshold", units="1", default=69.00594) - call get_param(param_file, mdl, "DUST_RATIO_TO_FE_BIOAVAIL_FRAC", CS%dust_ratio_to_fe_bioavail_frac, & - "ratio of dust to iron bioavailability fraction", units="1", default=1./366.314) - call get_param(param_file, mdl, "FE_BIOAVAIL_FRAC_OFFSET", CS%fe_bioavail_frac_offset, & - "offset for iron bioavailability fraction", units="1", default=0.0146756) + "coarse/fine dust ratio threshold", units="1", default=90.) call get_param(param_file, mdl, "ATM_FE_TO_BC_RATIO", CS%atm_fe_to_bc_ratio, & - "atmospheric iron to black carbon ratio", units="1", default=1.) - call get_param(param_file, mdl, "ATM_BC_FE_BIOAVAIL_FRAC", CS%atm_bc_fe_bioavail_frac, & - "atmospheric black carbon to iron bioavailablity fraction ratio", units="1", default=0.06) + "atmospheric iron to black carbon ratio", units="1", default=1.33) call get_param(param_file, mdl, "SEAICE_FE_TO_BC_RATIO", CS%seaice_fe_to_bc_ratio, & - "sea-ice iron to black carbon ratio", units="1", default=1.) - call get_param(param_file, mdl, "SEAICE_BC_FE_BIOAVAIL_FRAC", CS%seaice_bc_fe_bioavail_frac, & - "sea-ice black carbon to iron bioavailablity fraction ratio", units="1", default=0.06) + "sea-ice iron to black carbon ratio", units="1", default=1.33) 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="1", default=0.035) call get_param(param_file, mdl, "IRON_FRAC_IN_ATM_COARSE_DUST", CS%iron_frac_in_atm_coarse_dust, & @@ -161,26 +138,6 @@ subroutine MARBL_forcing_init(G, US, param_file, diag, day, inputdir, use_marbl, 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 @@ -199,13 +156,13 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust !! [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 [1] 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 !! [ppm] real, dimension(:,:), pointer, intent(in) :: atm_co2_diag !< Diagnostic atmospheric CO2 concentration !! [ppm] + real, dimension(:,:), pointer, intent(in) :: afracr !< open ocean fraction [1] real, dimension(:,:), pointer, intent(in) :: swnet_afracr !< shortwave flux * open ocean fraction !! [W m-2] real, dimension(:,:,:), pointer, intent(in) :: ifrac_n !< per-category ice fraction [1] @@ -225,6 +182,7 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust integer :: i, j, is, ie, js, je, m real :: atm_fe_bioavail_frac !< Fraction of iron from the atmosphere available for biological uptake [1] + real :: dust_ratio !< Ratio of coarse to fine dust from the atmosphere [1] real :: seaice_fe_bioavail_frac !< Fraction of iron from sea ice available for biological uptake [1] ! Note: following two conversion factors are used to both convert from km m-2 s-1 -> mmol m-2 s-1 !! AND cast in MOM6's unique dimensional consistency scaling system [conc Z T-1] @@ -233,31 +191,22 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust real :: ndep_conversion !< Factor to convert nitrogen deposition from kg m-2 s-1 -> mmol m-3 (m s-1) !! [s m2 kg-1 conc Z T-1 ~> mmol kg-1] - if (.not. CS%use_marbl_tracers) return + 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) iron_flux_conversion = (1.e6 / molw_Fe) * (US%m_to_Z * US%T_to_s) - ! 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 + ! Components of dust flux + fluxes%atm_fine_dust_flux(i,j) = (G%mask2dT(i,j) * US%kg_m2s_to_RZ_T) * atm_fine_dust_flux(i-i0,j-j0) + fluxes%atm_coarse_dust_flux(i,j) = (G%mask2dT(i,j) * US%kg_m2s_to_RZ_T) * atm_coarse_dust_flux(i-i0,j-j0) + fluxes%seaice_dust_flux(i,j) = (G%mask2dT(i,j) * US%kg_m2s_to_RZ_T) * seaice_dust_flux(i-i0,j-j0) + + ! Components of black carbon flux + fluxes%atm_bc_flux(i,j) = (G%mask2dT(i,j) * US%kg_m2s_to_RZ_T) * atm_bc_flux(i-i0,j-j0) + fluxes%seaice_bc_flux(i,j) = (G%mask2dT(i,j) * US%kg_m2s_to_RZ_T) * seaice_bc_flux(i-i0,j-j0) + ! 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) @@ -328,13 +277,15 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust 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)) + atm_fe_bioavail_frac = 0.005 + if ((atm_coarse_dust_flux(i-i0,j-j0) > 0.) .and. (atm_fine_dust_flux(i-i0,j-j0)) > 0.) then + dust_ratio = max(atm_coarse_dust_flux(i-i0,j-j0) / atm_fine_dust_flux(i-i0,j-j0), 9.903) else - atm_fe_bioavail_frac = CS%fe_bioavail_frac_offset + dust_ratio = 9.903 endif + dust_ratio = dust_ratio - 5.5 + if (dust_ratio < CS%dust_ratio_thres) & + atm_fe_bioavail_frac = dust_ratio**(-0.9) - 0.0134 ! Contribution of atmospheric dust to iron flux fluxes%iron_flux(i,j) = (atm_fe_bioavail_frac * & @@ -342,8 +293,8 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust 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))) + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (atm_bc_flux(i-i0,j-j0) * & + (atm_fe_bioavail_frac * CS%atm_fe_to_bc_ratio)) seaice_fe_bioavail_frac = atm_fe_bioavail_frac ! Contribution of seaice dust to iron flux @@ -351,8 +302,8 @@ subroutine convert_driver_fields_to_forcings(atm_fine_dust_flux, atm_coarse_dust (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))) + fluxes%iron_flux(i,j) = fluxes%iron_flux(i,j) + (seaice_bc_flux(i-i0,j-j0) * & + (seaice_fe_bioavail_frac * CS%seaice_fe_to_bc_ratio)) ! Unit conversion (kg m-2 s-1 -> conc Z T-1) fluxes%iron_flux(i,j) = (G%mask2dT(i,j) * iron_flux_conversion) * fluxes%iron_flux(i,j) diff --git a/src/tracer/MARBL_tracers.F90 b/src/tracer/MARBL_tracers.F90 index 20a600d171..a7bd64999e 100644 --- a/src/tracer/MARBL_tracers.F90 +++ b/src/tracer/MARBL_tracers.F90 @@ -36,7 +36,7 @@ module MARBL_tracers 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_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type use MOM_diag_mediator, only : register_diag_field, post_data!, safe_alloc_ptr @@ -137,8 +137,9 @@ module MARBL_tracers 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 + character(len=200) :: fesedflux_file !< name of [netCDF] file containing iron sediment flux + character(len=200) :: fesedfluxred_file !< name of [netCDF] file containing reduced 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] !! This variable contains D14C for each band [CU ~> conc] @@ -261,7 +262,9 @@ module MARBL_tracers 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 :: fesedflux_ind !< index of MARBL forcing field array to copy iron sediment flux into + integer :: fesedfluxred_ind !< index of MARBL forcing field array to copy reduced iron sediment flux into + integer :: feventflux_ind !< index of MARBL forcing field array to copy iron vent 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 @@ -290,8 +293,9 @@ module MARBL_tracers ! TODO: create generic 3D forcing input type to read z coordinate + values real :: fesedflux_scale_factor !< scale factor for iron sediment flux [mmol umol-1 d s-1] 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_in !< Field to read iron sediment flux into [conc m s-1] + real, allocatable, dimension(:,:,:) :: fesedfluxred_in !< Field to read reduced 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 it is easier to make thickness 0 @@ -500,6 +504,8 @@ subroutine configure_MARBL_tracers(GV, US, param_file, CS) CS%salinity_ind = -1 CS%pressure_ind = -1 CS%fesedflux_ind = -1 + CS%fesedfluxred_ind = -1 + CS%feventflux_ind = -1 CS%o2_scalef_ind = -1 CS%remin_scalef_ind = -1 CS%d14c_ind = -1 @@ -526,6 +532,10 @@ subroutine configure_MARBL_tracers(GV, US, param_file, CS) CS%pressure_ind = m case('Iron Sediment Flux') CS%fesedflux_ind = m + case('Iron Red Sediment Flux') + CS%fesedfluxred_ind = m + case('Iron Vent Flux') + CS%feventflux_ind = m case('O2 Consumption Scale Factor') CS%o2_scalef_ind = m case('Particulate Remin Scale Factor') @@ -631,16 +641,25 @@ function register_MARBL_tracers(HI, GV, US, param_file, CS, tr_Reg, restart_CS, ! ** 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") + default="fesedflux.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 + ! ** FESEDFLUXRED + call get_param(param_file, mdl, "MARBL_FESEDFLUXRED_FILE", CS%fesedfluxred_file, & + "The file in which the iron sediment flux forcing field can be found.", & + default="fesedfluxred.nc") + if (scan(CS%fesedfluxred_file,'/') == 0) then + ! Add the directory if CS%fesedflux_file is not already a complete path. + CS%fesedfluxred_file = trim(slasher(inputdir))//trim(CS%fesedfluxred_file) + call log_param(param_file, mdl, "INPUTDIR/MARBL_TRACERS_FESEDFLUXRED_FILE", CS%fesedfluxred_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") + default="feventflux.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) @@ -876,7 +895,7 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag 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 + logical :: fesedflux_has_edges, fesedflux_use_missing, tracer_init_from_Z real :: fesedflux_missing ! required argument for read_Z_edges() [CU ~> conc] integer :: i, j, k, kbot, m, diag_size @@ -955,6 +974,7 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag day, "Conversion Factor for Bottom Flux -> Tend", "1/m") ! Initialize tracers (if they weren't initialized from restart file) + tracer_init_from_Z = .false. do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, caller="initialize_MARBL_tracers") if ((.not. restart) .or. & @@ -963,12 +983,30 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag ! 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) + tracer_init_from_Z = .true. 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 + if (tracer_init_from_Z) then + ! For each column, enforce consistency in MARBL tracers + ! (no negative concentrations; for a given autotroph, if one tracer is 0 they all are) + call MOM_error(NOTE, 'Enforcing consistency across autotroph tracer initial conditions') + do j=G%jsc, G%jec ; do i=G%isc, G%iec + ! Copy tracer data into flat array + do k=1,GV%ke; do m=1, CS%ntr + MARBL_instances%tracers(m,k) = CS%tracer_data(m)%tr(i,j,k) + end do ; end do + ! call consistency enforcement + call MARBL_instances%autotroph_tracer_consistency_enforce() + ! Copy tracer data out of flat array + do k=1,GV%ke; do m=1, CS%ntr + CS%tracer_data(m)%tr(i,j,k) = MARBL_instances%tracers(m,k) + end do ; end do + end do ; end do + end if ! Initialize total chlorophyll to get SW Pen correct (if it wasn't initialized from restart file) if ((CS%total_Chl_ind > 0) .and. & @@ -1074,6 +1112,7 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag ! (2) Allocate memory for fesedflux and feventflux allocate(CS%fesedflux_in(SZI_(G), SZJ_(G), CS%fesedflux_nz)) + allocate(CS%fesedfluxred_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)) @@ -1081,6 +1120,8 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag ! 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%fesedfluxred_file, "FESEDFLUXIN", CS%fesedfluxred_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) @@ -1104,6 +1145,8 @@ subroutine initialize_MARBL_tracers(restart, day, G, GV, US, h, param_file, diag 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%fesedfluxred_in(i,j,k-1) = CS%fesedfluxred_in(i,j,k-1) + CS%fesedfluxred_in(i,j,k) + CS%fesedfluxred_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. @@ -1185,7 +1228,7 @@ subroutine register_MARBL_diags(MARBL_diags, diag, day, G, id_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 + if (trim(MARBL_diags%diags(m)%vertical_grid) == "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 @@ -1198,7 +1241,9 @@ subroutine register_MARBL_diags(MARBL_diags, diag, day, G, id_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 + if ((trim(MARBL_diags%diags(m)%short_name) == "FESEDFLUX") .or. & + (trim(MARBL_diags%diags(m)%short_name) == "FEREDSEDFLUX") .or. & + (trim(MARBL_diags%diags(m)%short_name) == "FEVENTFLUX")) 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 @@ -1272,15 +1317,13 @@ 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) +subroutine MARBL_tracers_column_physics(h_old, ea, eb, fluxes, dt, G, GV, US, CS, & + prediabatic_T, prediabatic_S, 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 @@ -1295,7 +1338,9 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 + real, dimension(:,:,:), intent(in) :: prediabatic_T !< Temperature prior to calling diabatic driver [C ~> degC] + real, dimension(:,:,:), intent(in) :: prediabatic_S !< Salinity prior to calling diabatic driver [S ~> ppt] + type(KPP_CS), optional, pointer :: KPP_CSp !< KPP control structure real, optional, intent(in) :: nonLocalTrans(:,:,:) !< Non-local transport [1] real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -1324,11 +1369,13 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, if (.not.associated(CS)) return - ! (1) Compute surface fluxes + ! (1) Compute surface fluxes and interior tendencies ! FIXME: MARBL can handle computing surface fluxes for all columns simultaneously ! I was just thinking going column-by-column at first might be easier + bot_flux_to_tend(:, :, :) = 0. do j=js,je do i=is,ie + ! Surface fluxes ! i. only want ocean points in this loop if (G%mask2dT(i,j) == 0) cycle @@ -1338,9 +1385,9 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, ! 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 + MARBL_instances%surface_flux_forcings(CS%sss_ind)%field_0d(1) = prediabatic_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 + MARBL_instances%surface_flux_forcings(CS%sst_ind)%field_0d(1) = prediabatic_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) @@ -1406,7 +1453,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 print_marbl_log(MARBL_instances%StatusLog, G, i, j) call MARBL_instances%StatusLog%erase() ! iv. Copy output that MOM6 needs to hold on to @@ -1432,158 +1479,15 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS%SFO(i,j,m) = MARBL_instances%surface_flux_output%outputs_for_GCM(m)%forcing_field_0d(1) enddo - enddo - enddo - - if (associated(fluxes%salt_flux)) then - ! 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 - endif - - 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, & - unscale=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, unscale=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 + ! interior tendencies + ! i. 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 + dz(k) = h_old(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 @@ -1605,22 +1509,22 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 + ! ii. 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 + MARBL_instances%interior_tendency_forcings(CS%potemp_ind)%field_1d(1,:) = prediabatic_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 + MARBL_instances%interior_tendency_forcings(CS%salinity_ind)%field_1d(1,:) = prediabatic_S(i,j,:) * US%S_to_ppt - ! This are okay, but need option to read in from file + ! This is 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?) + ! 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,:) @@ -1671,9 +1575,23 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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(:), & + CS%fesedflux_in(i,j,:), GV%ke, dz(:), & MARBL_instances%interior_tendency_forcings(CS%fesedflux_ind)%field_1d(1,:)) endif + if (CS%fesedfluxred_ind > 0) then + MARBL_instances%interior_tendency_forcings(CS%fesedfluxred_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%fesedfluxred_in(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%fesedfluxred_ind)%field_1d(1,:)) + endif + if (CS%feventflux_ind > 0) then + MARBL_instances%interior_tendency_forcings(CS%feventflux_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%feventflux_in(i,j,:), GV%ke, dz(:), & + MARBL_instances%interior_tendency_forcings(CS%feventflux_ind)%field_1d(1,:)) + endif ! TODO: add ability to read these fields from file ! also, add constant values to CS @@ -1694,7 +1612,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS%interior_tendency_saved_state(m)%field_3d(i,j,:) enddo - ! iv. Compute interior tendencies in MARBL + ! iii. 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(& @@ -1703,21 +1621,21 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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?) + ! iv. 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 + ! v. 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 + ! * 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 @@ -1733,7 +1651,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, endif enddo - ! * tendency values themselves (and vertical integrals of them) + ! * 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,:) @@ -1761,7 +1679,7 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, endif enddo - ! * Interior tendency output + ! * 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,:) @@ -1777,10 +1695,147 @@ subroutine MARBL_tracers_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, 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 (associated(fluxes%salt_flux)) then + ! 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 + endif + + 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, & + unscale=US%Z_to_m*US%s_to_T) + enddo + endif + + ! (2) 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, unscale=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 + ! TODO: do we want to support these options? does not apply river fluxes! + ! an alternative would be to require evap_CFL_limit and minimum_forcing_depth. + ! Much like we now require prediabatic_T and prediabatic_S, we can abort + ! in tracer flow control if they are not present. + 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 + + ! (3) Post diagnostics from our buffer + ! i. surface fluxes and their diagnostics (currently all 2D) + ! ii. Interior tendency diagnostics (mix of 2D and 3D) + ! iii. Interior tendencies themselves + ! iv. Forcing fields + 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 + if (CS%bot_flux_to_tend_id > 0) & call post_data(CS%bot_flux_to_tend_id, bot_flux_to_tend(:, :, :), CS%diag) @@ -2170,6 +2225,7 @@ subroutine MARBL_tracers_end(CS) 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%fesedfluxred_in)) deallocate(CS%fesedfluxred_in) if (allocated(CS%feventflux_in)) deallocate(CS%feventflux_in) if (allocated(CS%I_tau)) deallocate(CS%I_tau) deallocate(CS) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index a2d43e80a9..5241043309 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -53,7 +53,8 @@ module MOM_tracer_advect !> This routine time steps the tracer concentration using a !! monotonic, conservative, weakly diffusive scheme. subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first_in, & - vol_prev, max_iter_in, update_vol_prev, uhr_out, vhr_out) + vol_prev, max_iter_in, update_vol_prev, uhr_out, vhr_out, & + flux_type) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -71,7 +72,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry logical, optional, intent(in) :: x_first_in !< If present, indicate whether to update !! first in the x- or y-direction. - ! The remaining optional arguments are only used in offline tracer mode. + ! The next four optional arguments are only used in offline tracer mode. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(inout) :: vol_prev !< Cell volume before advection [H L2 ~> m3 or kg]. !! If update_vol_prev is true, the returned value is @@ -87,7 +88,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(out) :: vhr_out !< Remaining accumulated volume or mass fluxes !! through the meridional faces [H L2 ~> m3 or kg] - + ! The next optional argument is for diagnosing resolved vs parameterized tracer flux and control + ! which diagnostics are written. The tracers are only updated if flux_type = 0 (the default). Otherwise + ! the routines are dry run to collect diagnostics. + integer, optional, intent(in) :: flux_type !< Indicates whether uhtr, vhtr are the flux due to + !! the residual (= 0), resolved (= 1), or parameterized (= 2) + !! flow + + ! local variables + integer :: flux_type_ctrl !< To allow setting a default value for flux_type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & hprev ! cell volume at the end of previous tracer change [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & @@ -104,6 +113,12 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first logical :: domore_u(SZJ_(G),SZK_(GV)) ! domore_u and domore_v indicate whether there is more logical :: domore_v(SZJB_(G),SZK_(GV)) ! advection to be done in the corresponding row or column. logical :: x_first ! If true, advect in the x-direction first. + logical :: advect_this_tracer(Reg%ntr) ! If true, advect the mth tracer. Diagnostics of advection due to the + ! resolved and parameterized flow are collected by re-running the advection + ! routines with different advecting fluxes without updating the tracer. + ! This can be expensive if there are lots of tracers and only a few you + ! want diagnostics about. We therefore only calculate advection on the + ! tracers for which there are active resolved/parameterized diagnostics. integer :: max_iter ! maximum number of iterations in each layer integer :: domore_k(SZK_(GV)) integer :: stencil ! stencil of the advection scheme @@ -116,6 +131,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first domore_u(:,:) = .false. domore_v(:,:) = .false. + advect_this_tracer(:) = .false. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -162,6 +178,10 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first if (present(max_iter_in)) max_iter = max_iter_in if (present(x_first_in)) x_first = x_first_in + + flux_type_ctrl = 0 + if (present(flux_type)) flux_type_ctrl = flux_type ! default to residual flow + call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) @@ -213,15 +233,43 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first vh_neglect(i,J) = GV%H_subroundoff * MIN(G%areaT(i,j), G%areaT(i,j+1)) enddo ; enddo - ! initialize diagnostic fluxes and tendencies - !$OMP do - do m=1,ntr - if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 - if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 - if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 - if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 - if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 - enddo + ! initialize diagnostic fluxes and tendencies and determine which tracers to advect + if (flux_type_ctrl == 0) then ! Flux is residual + !$OMP do + do m=1,ntr + advect_this_tracer(m) = .true. ! Advect all the tracers regardless of diagnostic output + if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 + enddo + elseif (flux_type_ctrl == 1) then ! Flux is resolved + do m=1,ntr + if (associated(Reg%Tr(m)%ad_x_resolved)) then + Reg%Tr(m)%ad_x_resolved(:,:,:) = 0.0 + advect_this_tracer(m) = .true. ! advect this tracer + endif + if (associated(Reg%Tr(m)%ad_y_resolved)) then + Reg%Tr(m)%ad_y_resolved(:,:,:) = 0.0 + advect_this_tracer(m) = .true. ! advect this tracer + endif + enddo + elseif (flux_type_ctrl == 2) then ! Flux is parameterized + do m=1,ntr + if (associated(Reg%Tr(m)%ad_x_param)) then + Reg%Tr(m)%ad_x_param(:,:,:) = 0.0 + advect_this_tracer(m) = .true. ! advect this tracer + endif + if (associated(Reg%Tr(m)%ad_y_param)) then + Reg%Tr(m)%ad_y_param(:,:,:) = 0.0 + advect_this_tracer(m) = .true. ! advect this tracer + endif + enddo + else + call MOM_error(FATAL, & + "Inconsistent flux type in advect_tracer. Must be of 0 (residual), 1 (resolved), or 2 (parameterized)") + endif ! flux_type_ctrl !$OMP end parallel isv = is ; iev = ie ; jsv = js ; jev = je @@ -279,14 +327,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! First, advect zonally. call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, & - local_advect_scheme) + flux_type_ctrl, advect_this_tracer, local_advect_scheme) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect meridionally. call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) + isv, iev, jsv, jev, k, G, GV, US, flux_type_ctrl, advect_this_tracer, & + local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -302,14 +351,15 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! First, advect meridionally. call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, & - local_advect_scheme) + flux_type_ctrl, advect_this_tracer, local_advect_scheme) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect zonally. call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - isv, iev, jsv, jev, k, G, GV, US, local_advect_scheme) + isv, iev, jsv, jev, k, G, GV, US, flux_type_ctrl, advect_this_tracer, & + local_advect_scheme) ! Update domore_k(k) for the next iteration domore_k(k) = 0 @@ -355,7 +405,8 @@ end subroutine advect_tracer !> This subroutine does 1-d flux-form advection in the zonal direction using !! a monotonic piecewise linear scheme. subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & - is, ie, js, je, k, G, GV, US, advect_schemes) + is, ie, js, je, k, G, GV, US, flux_type, advect_this_tracer, & + advect_schemes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: ntr !< The number of tracers @@ -376,6 +427,10 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & integer, intent(in) :: je !< The ending tracer j-index to work on integer, intent(in) :: k !< The k-level to work on type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: flux_type !< Indicates whether uhtr, vhtr are the flux + !! due to the residual (= 0), resolved (= 1), + !! or parameterized (= 2) flow + logical, dimension(ntr), intent(in) :: advect_this_tracer !< If true, advect this tracer integer, dimension(ntr), intent(in) :: advect_schemes !< list of advection schemes to use real, dimension(SZI_(G),ntr) :: & @@ -439,34 +494,40 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! Calculate the i-direction profiles (slopes) of each tracer that is being advected. if (usePLMslope) then - do m=1,ntr ; do i=is-stencil,ie+stencil - !if (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) < & - ! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k))) then - ! maxslope = 4.0*(Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) - !else - ! maxslope = 4.0*(Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k)) - !endif - !if ((Tr(m)%t(i+1,j,k)-Tr(m)%t(i,j,k)) * (Tr(m)%t(i,j,k)-Tr(m)%t(i-1,j,k)) < 0.0) then - ! slope_x(i,m) = 0.0 - !elseif (ABS(Tr(m)%t(i+1,j,k)-Tr(m)%t(i-1,j,k))= 0.0) then + i_up = i + else + i_up = i+1 + endif - if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then - do I=is-1,ie - ! centre cell depending on upstream direction - if (uhh(I) >= 0.0) then - i_up = i - else - i_up = i+1 - endif - - ! Implementation of PPM-H3 - Tp = T_tmp(i_up+1,m) ; Tc = T_tmp(i_up,m) ; Tm = T_tmp(i_up-1,m) - - if (advect_schemes(m) == ADVECT_PPMH3) then - aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate - aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound - aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate - aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound - else - aL = 0.5 * ((Tm + Tc) + (slope_x(i_up-1,m) - slope_x(i_up,m)) / 3.) - aR = 0.5 * ((Tc + Tp) + (slope_x(i_up,m) - slope_x(i_up+1,m)) / 3.) - endif + ! Implementation of PPM-H3 + Tp = T_tmp(i_up+1,m) ; Tc = T_tmp(i_up,m) ; Tm = T_tmp(i_up-1,m) + + if (advect_schemes(m) == ADVECT_PPMH3) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_x(i_up-1,m) - slope_x(i_up,m)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_x(i_up,m) - slope_x(i_up+1,m)) / 3.) + endif - dA = aR - aL ; mA = 0.5*( aR + aL ) - if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells - elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = (3.*Tc) - 2.*aR - elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = (3.*Tc) - 2.*aL - endif + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = (3.*Tc) - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = (3.*Tc) - 2.*aL + endif - a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature - if (uhh(I) >= 0.0) then - flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & - ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) - else - flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & - ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) - endif - enddo - else ! PLM - do I=is-1,ie - if (uhh(I) >= 0.0) then - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) - !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m) - flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) - else - ! Indirect implementation of PLM - !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) - !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) - !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) - ! Alternative implementation of PLM - Tc = T_tmp(i+1,m) - flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) - endif - enddo - endif ! usePPM + if (uhh(I) >= 0.0) then + flux_x(I,j,m) = uhh(I)*( aR - 0.5 * CFL(I) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_x(I,j,m) = uhh(I)*( aL + 0.5 * CFL(I) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo + else ! PLM + do I=is-1,ie + if (uhh(I) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_x(i,m) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_x(i,m) + !flux_x(I,j,m) = uhh(I)*( aR - 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m) + flux_x(I,j,m) = uhh(I)*( Tc + 0.5 * slope_x(i,m) * ( 1. - CFL(I) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i+1,j,k) - 0.5 * slope_x(i+1,m) + !aR = Tr(m)%t(i+1,j,k) + 0.5 * slope_x(i+1,m) + !flux_x(I,j,m) = uhh(I)*( aL + 0.5 * (aR-aL) * CFL(I) ) + ! Alternative implementation of PLM + Tc = T_tmp(i+1,m) + flux_x(I,j,m) = uhh(I)*( Tc - 0.5 * slope_x(i+1,m) * ( 1. - CFL(I) ) ) + endif + enddo + endif ! usePPM + endif ! advect_this_tracer enddo if (associated(OBC)) then ; if (OBC%OBC_pe) then @@ -625,9 +691,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! should the reservoir evolve for this case Kate ?? - Nope do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + if (advect_this_tracer(ntr_id)) then + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + endif ! advect_this_tracer enddo endif endif @@ -649,9 +717,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & uhh(I) = uhr(I,j,k) do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + if (advect_this_tracer(ntr_id)) then + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + endif ! advect_this_tracer enddo endif endif @@ -694,16 +764,44 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! update tracer concentration from i-flux and save some diagnostics do m=1,ntr + if (advect_this_tracer(m)) then - ! update tracer - do i=is,ie - if (do_i(i,j)) then - if (Ihnew(i) > 0.0) then - Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & - (flux_x(I,j,m) - flux_x(I-1,j,m))) * Ihnew(i) + ! update tracer + if (flux_type == 0) then ! Only update tracer if using residual flux + do i=is,ie + if (do_i(i,j)) then + if (Ihnew(i) > 0.0) then + Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & + (flux_x(I,j,m) - flux_x(I-1,j,m))) * Ihnew(i) + endif + endif + enddo + endif ! flux_type == 0 + + ! diagnostics + if (flux_type == 0) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt + endif ; enddo ; endif + + ! diagnose convergence of flux_x (do not use the Ihnew(i) part of the logic). + ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. + if (associated(Tr(m)%advection_xy)) then + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_x(I,j,m) - flux_x(I-1,j,m)) * & + Idt * G%IareaT(i,j) + endif ; enddo endif - endif - enddo + elseif (flux_type == 1) then + if (associated(Tr(m)%ad_x_resolved)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + Tr(m)%ad_x_resolved(I,j,k) = Tr(m)%ad_x_resolved(I,j,k) + flux_x(I,j,m)*Idt + endif ; enddo ; endif + elseif (flux_type == 2) then + if (associated(Tr(m)%ad_x_param)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + Tr(m)%ad_x_param(I,j,k) = Tr(m)%ad_x_param(I,j,k) + flux_x(I,j,m)*Idt + endif ; enddo ; endif + endif ! the case of flux_type not equal 0, 1, or 2 is caught in advect_tracer above. + endif ! advect_this_tracer ! diagnostics if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then @@ -719,36 +817,40 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & Idt * G%IareaT(i,j) endif ; enddo endif - enddo endif ; enddo ! End of j-loop. ! Do user controlled underflow of the tracer concentrations. - do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then - do j=js,je ; do i=is,ie - if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 - enddo ; enddo - endif ; enddo + if (flux_type == 0) then ! Only update tracer if using residual flux + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo + endif ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. - !$OMP ordered - do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then - do j=js,je ; if (domore_u_initial(j,k)) then - do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then - Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt + if (flux_type == 0) then ! Only update tracer if using residual flux + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then + do j=js,je ; if (domore_u_initial(j,k)) then + do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then + Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt + endif ; enddo endif ; enddo - endif ; enddo - endif ; enddo ! End of m-loop. - !$OMP end ordered + endif ; enddo ! End of m-loop. + !$OMP end ordered + endif end subroutine advect_x !> This subroutine does 1-d flux-form advection using a monotonic piecewise !! linear scheme. subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & - is, ie, js, je, k, G, GV, US, advect_schemes) + is, ie, js, je, k, G, GV, US, flux_type, advect_this_tracer, & + advect_schemes) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure integer, intent(in) :: ntr !< The number of tracers @@ -769,6 +871,10 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & integer, intent(in) :: je !< The ending tracer j-index to work on integer, intent(in) :: k !< The k-level to work on type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: flux_type !< Indicates whether uhtr, vhtr are the flux + !! due to the residual (= 0), resolved (= 1), + !! or parameterized (= 2) flow + logical, dimension(ntr), intent(in) :: advect_this_tracer !< If true, advect this tracer integer, dimension(ntr), intent(in) :: advect_schemes !< list of advection schemes to use real, dimension(SZI_(G),ntr,SZJ_(G)) :: & @@ -840,35 +946,43 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! Calculate the j-direction profiles (slopes) of each tracer that ! is being advected. if (usePLMslope) then - do j=js-stencil,je+stencil ; if (do_j_tr(j)) then ; do m=1,ntr ; do i=is,ie - !if (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k)) < & - ! ABS(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k))) then - ! maxslope = 4.0*(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k)) - !else - ! maxslope = 4.0*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k)) - !endif - !if ((Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j,k))*(Tr(m)%t(i,j,k)-Tr(m)%t(i,j-1,k)) < 0.0) then - ! slope_y(i,m,j) = 0.0 - !elseif (ABS(Tr(m)%t(i,j+1,k)-Tr(m)%t(i,j-1,k))= 0.0) then + j_up = j + else + j_up = j + 1 + endif - if ((advect_schemes(m) == ADVECT_PPM) .or. (advect_schemes(m) == ADVECT_PPMH3)) then - do i=is,ie - ! centre cell depending on upstream direction - if (vhh(i,J) >= 0.0) then - j_up = j - else - j_up = j + 1 - endif - - ! Implementation of PPM-H3 - Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) - - if (advect_schemes(m) == ADVECT_PPMH3) then - aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate - aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound - aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate - aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound - else - aL = 0.5 * ((Tm + Tc) + (slope_y(i,m,j_up-1) - slope_y(i,m,j_up)) / 3.) - aR = 0.5 * ((Tc + Tp) + (slope_y(i,m,j_up) - slope_y(i,m,j_up+1)) / 3.) - endif + ! Implementation of PPM-H3 + Tp = T_tmp(i,m,j_up+1) ; Tc = T_tmp(i,m,j_up) ; Tm = T_tmp(i,m,j_up-1) + + if (advect_schemes(m) == ADVECT_PPMH3) then + aL = ( 5.*Tc + ( 2.*Tm - Tp ) )/6. ! H3 estimate + aL = max( min(Tc,Tm), aL) ; aL = min( max(Tc,Tm), aL) ! Bound + aR = ( 5.*Tc + ( 2.*Tp - Tm ) )/6. ! H3 estimate + aR = max( min(Tc,Tp), aR) ; aR = min( max(Tc,Tp), aR) ! Bound + else + aL = 0.5 * ((Tm + Tc) + (slope_y(i,m,j_up-1) - slope_y(i,m,j_up)) / 3.) + aR = 0.5 * ((Tc + Tp) + (slope_y(i,m,j_up) - slope_y(i,m,j_up+1)) / 3.) + endif - dA = aR - aL ; mA = 0.5*( aR + aL ) - if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells - elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then - aL = (3.*Tc) - 2.*aR - elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then - aR = (3.*Tc) - 2.*aL - endif + dA = aR - aL ; mA = 0.5*( aR + aL ) + if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells + elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then + aL = (3.*Tc) - 2.*aR + elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then + aR = (3.*Tc) - 2.*aL + endif - a6 = 6.*Tc - 3. * (aR + aL) ! Curvature + a6 = 6.*Tc - 3. * (aR + aL) ! Curvature - if (vhh(i,J) >= 0.0) then - flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * CFL(i) * ( & - ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) - else - flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * CFL(i) * ( & - ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) - endif - enddo - else ! PLM - do i=is,ie - if (vhh(i,J) >= 0.0) then - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j) - !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) - !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m,j) - flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) - else - ! Indirect implementation of PLM - !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) - !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) - !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) - ! Alternative implementation of PLM - Tc = T_tmp(i,m,j+1) - flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) - endif - enddo - endif ! usePPM + if (vhh(i,J) >= 0.0) then + flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * CFL(i) * ( & + ( aR - aL ) - a6 * ( 1. - 2./3. * CFL(I) ) ) ) + else + flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * CFL(i) * ( & + ( aR - aL ) + a6 * ( 1. - 2./3. * CFL(I) ) ) ) + endif + enddo + else ! PLM + do i=is,ie + if (vhh(i,J) >= 0.0) then + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j,k) - 0.5 * slope_y(i,m,j) + !aR = Tr(m)%t(i,j,k) + 0.5 * slope_y(i,m,j) + !flux_y(i,m,J) = vhh(i,J)*( aR - 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j) + flux_y(i,m,J) = vhh(i,J)*( Tc + 0.5 * slope_y(i,m,j) * ( 1. - CFL(i) ) ) + else + ! Indirect implementation of PLM + !aL = Tr(m)%t(i,j+1,k) - 0.5 * slope_y(i,m,j+1) + !aR = Tr(m)%t(i,j+1,k) + 0.5 * slope_y(i,m,j+1) + !flux_y(i,m,J) = vhh(i,J)*( aL + 0.5 * (aR-aL) * CFL(i) ) + ! Alternative implementation of PLM + Tc = T_tmp(i,m,j+1) + flux_y(i,m,J) = vhh(i,J)*( Tc - 0.5 * slope_y(i,m,j+1) * ( 1. - CFL(i) ) ) + endif + enddo + endif ! usePPM + endif ! advect_this_tracer enddo if (associated(OBC)) then ; if (OBC%OBC_pe) then @@ -1030,11 +1149,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & vhh(i,J) = vhr(i,J,k) do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) - else - flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc - endif + if (advect_this_tracer(ntr_id)) then + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + endif ! advect_this_tracer enddo endif enddo @@ -1056,9 +1175,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & vhh(i,J) = vhr(i,J,k) do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index - if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + if (advect_this_tracer(ntr_id)) then + if (allocated(segment%tr_Reg%Tr(m)%tres)) then + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + endif ! advect_this_tracer enddo endif enddo @@ -1069,7 +1190,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & else ! not domore_v. do i=is,ie ; vhh(i,J) = 0.0 ; enddo - do m=1,ntr ; do i=is,ie ; flux_y(i,m,J) = 0.0 ; enddo ; enddo + do m=1,ntr + if (advect_this_tracer(m)) then + do i=is,ie ; flux_y(i,m,J) = 0.0 ; enddo + endif ! advect_this_tracer + enddo endif ; enddo ! End of j-loop do J=js-1,je ; do i=is,ie @@ -1107,49 +1232,75 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! update tracer and save some diagnostics do m=1,ntr - do i=is,ie ; if (do_i(i,j)) then - Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & - (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) - endif ; enddo - - ! diagnose convergence of flux_y and add to convergence of flux_x. - ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. - if (associated(Tr(m)%advection_xy)) then - do i=is,ie ; if (do_i(i,j)) then - Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - & - (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & - G%IareaT(i,j) - endif ; enddo - endif + if (advect_this_tracer(m)) then + if (flux_type == 0) then ! Only update tracer if using residual flux + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%t(i,j,k) = (Tr(m)%t(i,j,k) * hlst(i) - & + (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) + endif ; enddo + ! diagnose convergence of flux_y and add to convergence of flux_x. + ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. + if (associated(Tr(m)%advection_xy)) then + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%advection_xy(i,j,k) = Tr(m)%advection_xy(i,j,k) - (flux_y(i,m,J) - flux_y(i,m,J-1))* Idt * & + G%IareaT(i,j) + endif ; enddo + endif + endif ! flux_type == 0 + endif ! advect_this_tracer enddo endif ; enddo ! End of j-loop. ! Do user controlled underflow of the tracer concentrations. - do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then - do j=js,je ; do i=is,ie - if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 - enddo ; enddo - endif ; enddo + if (flux_type == 0) then ! Only update tracer if using residual flux + do m=1,ntr ; if (Tr(m)%conc_underflow > 0.0) then + do j=js,je ; do i=is,ie + if (abs(Tr(m)%t(i,j,k)) < Tr(m)%conc_underflow) Tr(m)%t(i,j,k) = 0.0 + enddo ; enddo + endif ; enddo + endif ! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. - !$OMP ordered - do m=1,ntr ; if (associated(Tr(m)%ad_y)) then - do J=js-1,je ; if (domore_v_initial(J)) then - do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + if (flux_type == 0) then + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo endif ; enddo - endif ; enddo - endif ; enddo ! End of m-loop. + endif ; enddo ! End of m-loop. - do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then - do J=js-1,je ; if (domore_v_initial(J)) then - do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then - Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt + do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt + endif ; enddo endif ; enddo - endif ; enddo - endif ; enddo ! End of m-loop. - !$OMP end ordered + endif ; enddo ! End of m-loop. + !$OMP end ordered + elseif (flux_type == 1) then + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad_y_resolved)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + Tr(m)%ad_y_resolved(i,J,k) = Tr(m)%ad_y_resolved(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + !$OMP end ordered + elseif (flux_type == 2) then + !$OMP ordered + do m=1,ntr ; if (associated(Tr(m)%ad_y_param)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then + Tr(m)%ad_y_param(i,J,k) = Tr(m)%ad_y_param(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + !$OMP end ordered + endif ! the case of flux_type not equal 0, 1, or 2 is caught in advect_tracer above. end subroutine advect_y diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index dc8f3a37fb..33db88fe3f 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -83,7 +83,7 @@ module MOM_tracer_flow_control public call_tracer_register, tracer_flow_control_init, call_tracer_set_forcing public call_tracer_column_fns, call_tracer_surface_state, call_tracer_stocks public call_tracer_flux_init, get_chl_from_model, tracer_flow_control_end -public call_tracer_register_obc_segments +public call_tracer_register_obc_segments, extract_tracer_flow_member !> The control structure for orchestrating the calling of tracer packages type, public :: tracer_flow_control_CS ; private @@ -203,7 +203,7 @@ 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, & + 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, & @@ -417,6 +417,17 @@ subroutine get_chl_from_model(Chl_array, G, GV, CS) end subroutine get_chl_from_model +!> Returns pointers or values of members within the tracer_flow_control_CS type. For extensibility, +!! each returned argument is an optional argument +subroutine extract_tracer_flow_member(CS, use_MARBL_tracers) + type(tracer_flow_control_CS), target, intent(in) :: CS !< module control structure + ! All output arguments are optional + logical, optional, intent(out) :: use_MARBL_tracers !< If true, MARBL tracers are active + + ! Constants within tracer_flow_control_CS + if (present(use_MARBL_tracers)) use_MARBL_tracers = CS%use_MARBL_tracers +end subroutine extract_tracer_flow_member + !> This subroutine calls the individual tracer modules' subroutines to !! specify or read quantities related to their surface forcing. subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) @@ -452,7 +463,8 @@ end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, US, tv, optics, CS, & - debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth, h_BL) + debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth, & + h_BL, prediabatic_T, prediabatic_S) 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(in) :: h_old !< Layer thickness before entrainment @@ -488,6 +500,10 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over !! which fluxes can be applied [H ~> m or kg m-2] real, dimension(:,:), optional, pointer :: h_BL !< Thickness of active mixing layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: prediabatic_T !< Temperature prior to calling + !! diabatic driver [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: prediabatic_S !< Salinity prior to calling + !! diabatic driver [S ~> ppt] ! Local variables real :: Hbl(SZI_(G),SZJ_(G)) !< Boundary layer thickness [H ~> m or kg m-2] @@ -529,13 +545,17 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, Hbl=Hbl) endif - 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, & + if (CS%use_MARBL_tracers) then + if ((.not. present(prediabatic_T)) .or. (.not. present(prediabatic_S))) & + call MOM_error(FATAL, 'Must pass prediabatic_T and prediabatic_S when using MARBL') + call MARBL_tracers_column_physics(h_old, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, & + prediabatic_T, prediabatic_S, & KPP_CSp=KPP_CSp, & nonLocalTrans=nonLocalTrans, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) + endif 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, & @@ -619,11 +639,15 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hbl) endif - 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, & + if (CS%use_MARBL_tracers) then + if ((.not. present(prediabatic_T)) .or. (.not. present(prediabatic_S))) & + call MOM_error(FATAL, 'Must pass prediabatic_T and prediabatic_S when using MARBL') + call MARBL_tracers_column_physics(h_old, ea, eb, fluxes, dt, & + G, GV, US, CS%MARBL_tracers_CSp, & + prediabatic_T, prediabatic_S, & KPP_CSp=KPP_CSp, & nonLocalTrans=nonLocalTrans) + endif 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) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 3e8429f884..c550f73ef5 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -507,21 +507,43 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ enddo enddo enddo + if (CS%KhTr_use_vert_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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + Coef_min = I_numitts * dt * (CS%KhTr_min*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Coef_y(i,J,K) = max(Coef_y(i,J,K), Coef_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%khtr_struct(i,j,k-1) + VarMix%khtr_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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + Coef_min = I_numitts * dt * (CS%KhTr_min*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Coef_x(I,j,K) = max(Coef_x(I,j,K), Coef_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 @@ -635,13 +657,24 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo if (CS%KhTr_use_vert_struct) then - 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + if (CS%full_depth_khtr_min) then + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + Kh_u(I,j,K) = max(Kh_u(I,j,K), CS%KhTr_min) + enddo enddo enddo - enddo + else + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif endif !call post_data(CS%id_KhTr_u, Kh_u, CS%diag, is_static=.false., mask=G%mask2dCu) call post_data(CS%id_KhTr_u, Kh_u, CS%diag) @@ -651,13 +684,24 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo if (CS%KhTr_use_vert_struct) then - 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + if (CS%full_depth_khtr_min) then + 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%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + Kh_v(i,J,K) = max(Kh_v(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 + Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%khtr_struct(i,j,k-1) + VarMix%khtr_struct(i,j+1,k-1) ) + enddo + enddo + enddo + endif endif !call post_data(CS%id_KhTr_v, Kh_v, CS%diag, is_static=.false., mask=G%mask2dCv) call post_data(CS%id_KhTr_v, Kh_v, CS%diag) @@ -677,10 +721,19 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_ 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%KhTr_use_vert_struct) then - do K=2,nz+1 - Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%khtr_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))) - enddo + if (CS%full_depth_khtr_min) then + do K=2,nz+1 + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%khtr_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))) + Kh_h(i,j,K) = max(Kh_h(i,j,K), CS%KhTr_min) + enddo + + else + do K=2,nz+1 + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%khtr_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))) + enddo + endif endif enddo ; enddo !call post_data(CS%id_KhTr_h, Kh_h, CS%diag, is_static=.false., mask=G%mask2dT) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 50220be343..08860c3ccb 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -18,11 +18,13 @@ module MOM_tracer_registry use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : vardesc, query_vardesc, cmor_long_std use MOM_restart, only : register_restart_field, MOM_restart_CS use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type use MOM_tracer_types, only : tracer_type, tracer_registry_type @@ -34,6 +36,7 @@ module MOM_tracer_registry public MOM_tracer_chksum, MOM_tracer_chkinv public register_tracer_diagnostics public post_tracer_diagnostics_at_sync, post_tracer_transport_diagnostics +public post_tracer_integral_diagnostics public preALE_tracer_diagnostics, postALE_tracer_diagnostics public tracer_registry_init, lock_tracer_registry, tracer_registry_end public tracer_name_lookup @@ -365,6 +368,22 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesCvL, Time, trim(flux_longname)//" advective meridional flux" , & trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_adx_resolved = register_diag_field("ocean_model", trim(shortnm)//"_adx_resolved", & + diag%axesCuL, Time, trim(flux_longname)//" resolved advective zonal flux" , & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_ady_resolved = register_diag_field("ocean_model", trim(shortnm)//"_ady_resolved", & + diag%axesCvL, Time, trim(flux_longname)//" resolved advective meridional flux" , & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_adx_param = register_diag_field("ocean_model", trim(shortnm)//"_adx_param", & + diag%axesCuL, Time, trim(flux_longname)//" parameterized advective zonal flux" , & + trim(flux_units), v_extensive=.true., y_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) + Tr%id_ady_param = register_diag_field("ocean_model", trim(shortnm)//"_ady_param", & + diag%axesCvL, Time, trim(flux_longname)//" resolved parameterized meridional flux" , & + trim(flux_units), v_extensive=.true., x_cell_method='sum', & + conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T) Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_dfx", & diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux" , & trim(flux_units), v_extensive=.true., y_cell_method='sum', & @@ -389,6 +408,18 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u Tr%id_ady = register_diag_field("ocean_model", trim(shortnm)//"_ady", & diag%axesCvL, Time, "Advective (by residual mean) Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') + Tr%id_adx_resolved = register_diag_field("ocean_model", trim(shortnm)//"_adx_resolved", & + diag%axesCuL, Time, "Advective (by resolved flow) Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') + Tr%id_ady_resolved = register_diag_field("ocean_model", trim(shortnm)//"_ady_resolved", & + diag%axesCvL, Time, "Advective (by resolved flow) Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') + Tr%id_adx_param = register_diag_field("ocean_model", trim(shortnm)//"_adx_param", & + diag%axesCuL, Time, "Advective (by parameterized flow) Zonal Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, y_cell_method='sum') + Tr%id_ady_param = register_diag_field("ocean_model", trim(shortnm)//"_ady_param", & + diag%axesCvL, Time, "Advective (by parameterized flow) Meridional Flux of "//trim(flux_longname), & + flux_units, v_extensive=.true., conversion=Tr%flux_scale*(US%L_to_m**2)*US%s_to_T, x_cell_method='sum') Tr%id_dfx = register_diag_field("ocean_model", trim(shortnm)//"_diffx", & diag%axesCuL, Time, "Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & @@ -411,15 +442,19 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u Tr%id_zint = register_diag_field("ocean_model", trim(shortnm)//"_zint", & diag%axesT1, Time, & "Thickness-weighted integral of " // trim(longname), & - trim(units) // " m") + trim(units) // " m", conversion=Tr%conc_scale*US%Z_to_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") + trim(units) // " m", conversion=Tr%conc_scale*US%Z_to_m) Tr%id_surf = register_diag_field("ocean_model", trim(shortnm)//"_SURF", & - diag%axesT1, Time, "Surface values of "// trim(longname), trim(units)) + diag%axesT1, Time, "Surface values of "// trim(longname), trim(units), conversion=Tr%conc_scale) 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_adx_resolved > 0) call safe_alloc_ptr(Tr%ad_x_resolved,IsdB,IedB,jsd,jed,nz) + if (Tr%id_ady_resolved > 0) call safe_alloc_ptr(Tr%ad_y_resolved,isd,ied,JsdB,JedB,nz) + if (Tr%id_adx_param > 0) call safe_alloc_ptr(Tr%ad_x_param,IsdB,IedB,jsd,jed,nz) + if (Tr%id_ady_param > 0) call safe_alloc_ptr(Tr%ad_y_param,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) if (Tr%id_hbd_dfx > 0) call safe_alloc_ptr(Tr%hbd_dfx,IsdB,IedB,jsd,jed,nz) @@ -762,50 +797,22 @@ 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, khi + integer :: i, j, k, is, ie, js, je, nz, m real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated convergence of lateral advective ! tracer fluxes [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] - real :: frac_under_100m(SZI_(G),SZJ_(G),SZK_(GV)) ! weights used to compute 100m vertical integrals [nondim] - real :: ztop(SZI_(G),SZJ_(G)) ! position of the top interface [H ~> m or kg m-2] - real :: zbot(SZI_(G),SZJ_(G)) ! position of the bottom interface [H ~> m or kg m-2] 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) if (Tr%id_adx > 0) call post_data(Tr%id_adx, Tr%ad_x, diag, alt_h=h_diag) if (Tr%id_ady > 0) call post_data(Tr%id_ady, Tr%ad_y, diag, alt_h=h_diag) + if (Tr%id_adx_resolved > 0) call post_data(Tr%id_adx_resolved, Tr%ad_x_resolved, diag, alt_h=h_diag) + if (Tr%id_ady_resolved > 0) call post_data(Tr%id_ady_resolved, Tr%ad_y_resolved, diag, alt_h=h_diag) + if (Tr%id_adx_param > 0) call post_data(Tr%id_adx_param, Tr%ad_x_param, diag, alt_h=h_diag) + if (Tr%id_ady_param > 0) call post_data(Tr%id_ady_param, Tr%ad_y_param, diag, alt_h=h_diag) if (Tr%id_dfx > 0) call post_data(Tr%id_dfx, Tr%df_x, diag, alt_h=h_diag) if (Tr%id_dfy > 0) call post_data(Tr%id_dfy, Tr%df_y, diag, alt_h=h_diag) if (Tr%id_adx_2d > 0) call post_data(Tr%id_adx_2d, Tr%ad2d_x, diag) @@ -820,13 +827,83 @@ 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 + endif ; enddo +end subroutine post_tracer_transport_diagnostics + +!> Post diagnostics of vertically integrated tracer amouints +subroutine post_tracer_integral_diagnostics(G, GV, US, Reg, h_diag, tv, diag) + 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tracer_registry_type), pointer :: Reg !< pointer to the tracer registry + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_diag !< Layer thicknesses on which to post fields [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables. + type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output + + integer :: i, j, k, is, ie, js, je, nz, m, khi + real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated tracer amounts [CU Z T-1 ~> conc m] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) !< Geometric layer thicknesses in height units [Z ~> m] + real :: frac_under_100m(SZI_(G),SZJ_(G),SZK_(GV)) ! weights used to compute 100m vertical integrals [nondim] + real :: ztop(SZI_(G),SZJ_(G)) ! position of the top interface [Z ~> m] + real :: zbot(SZI_(G),SZJ_(G)) ! position of the bottom interface [Z ~> m] + real :: Z_100 ! 100 m in depth units [Z ~> m] + logical :: dz_needed, dz100_used + type(tracer_type), pointer :: Tr=>NULL() + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + dz_needed = .false. + dz100_used = .false. + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + if (Reg%Tr(m)%id_zint_100m > 0) dz100_used = .true. + if (Reg%Tr(m)%id_zint > 0) dz_needed = .true. + endif ; enddo + if (dz100_used) dz_needed = .true. + + if (dz_needed) then + ! Convert the layer thicknesses into geometric depths, using the pre-stored layer-mean specific + ! volumes when in non-Boussinesq mode. + call thickness_to_dz(h_diag, tv, dz, G, GV, US) + endif + + if (dz100_used) then + ! 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 + + Z_100 = 100.0*US%m_to_Z + 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) + dz(i,j,k) + if (zbot(i,j) <= Z_100) then + frac_under_100m(i,j,k) = 1.0 + elseif (ztop(i,j) < Z_100) then + frac_under_100m(i,j,k) = (Z_100 - 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, (Z_100 - ztop(i,j)) / (zbot(i,j) - ztop(i,j)))) + enddo ; enddo + if (any(frac_under_100m(:,:,k) > 0)) khi = k + enddo + endif + + do m=1,Reg%ntr ; if (Reg%Tr(m)%registry_diags) then + Tr => Reg%Tr(m) ! 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) + work2d(i,j) = work2d(i,j) + dz(i,j,k)*tr%t(i,j,k) enddo ; enddo ; enddo call post_data(Tr%id_zint, work2d, diag) endif @@ -835,7 +912,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) 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)) + work2d(i,j) = work2d(i,j) + frac_under_100m(i,j,k) * dz(i,j,k)*Tr%t(i,j,k) enddo ; enddo ; enddo call post_data(Tr%id_zint_100m, work2d, diag) endif @@ -844,7 +921,7 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) if (Tr%id_SURF > 0) call post_data(Tr%id_SURF, Tr%t(:,:,1), diag) endif ; enddo -end subroutine post_tracer_transport_diagnostics +end subroutine post_tracer_integral_diagnostics !> This subroutine writes out chksums for the first ntr registered tracers. subroutine tracer_array_chksum(mesg, Tr, ntr, G) diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index 730a453695..68a6f7da4f 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -23,6 +23,14 @@ module MOM_tracer_types !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: ad_y => NULL() !< diagnostic array for y-advective tracer flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_x_resolved => NULL() !< diagnostic array for x-advective resolved tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_y_resolved => NULL() !< diagnostic array for y-advective resolved tracer flux + !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_x_param => NULL() !< diagnostic array for x-advective parameterized tracer + !! flux [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: ad_y_param => NULL() !< diagnostic array for y-advective parameterized tracer + !! flux [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_x => NULL() !< diagnostic vertical sum x-advective tracer flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: ad2d_y => NULL() !< diagnostic vertical sum y-advective tracer flux @@ -109,6 +117,7 @@ module MOM_tracer_types !>@{ Diagnostic IDs integer :: id_tr = -1, id_tr_post_horzn = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 + integer :: id_adx_resolved = -1, id_ady_resolved = -1, id_adx_param = -1, id_ady_param = -1 integer :: id_hbd_dfx = -1, id_hbd_dfy = -1 integer :: id_hbd_dfx_2d = -1, id_hbd_dfy_2d = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1