diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 4a07c0b639..2d99b45967 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -28,7 +28,3 @@ jobs: - name: Compile MOM6 for the NUOPC driver shell: bash run: make check_mom6_api_nuopc -j - - - name: Compile MOM6 for the MCT driver - shell: bash - run: make check_mom6_api_mct -j diff --git a/.testing/Makefile b/.testing/Makefile index b11532f93c..6d2dc2addd 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -255,7 +255,6 @@ build/opt/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) build/opt_target/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) build/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/mct/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/cov/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) build/unit/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) @@ -269,7 +268,6 @@ build/opt/Makefile: MOM_ACFLAGS= build/opt_target/Makefile: MOM_ACFLAGS= build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_cap build/cov/Makefile: MOM_ACFLAGS= build/unit/Makefile: MOM_ACFLAGS=--with-driver=unit_tests @@ -370,11 +368,6 @@ build/coupled/ocean_model_MOM.o: build/coupled/Makefile cd $(@D) && make $(@F) check_mom6_api_coupled: build/coupled/ocean_model_MOM.o -# MCT driver -build/mct/mom_ocean_model_mct.o: build/mct/Makefile - cd $(@D) && make $(@F) -check_mom6_api_mct: build/mct/mom_ocean_model_mct.o - #--- # Testing diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/mom_ocean_model_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 diff --git a/config_src/drivers/mct_cap/ocn_cap_methods.F90 b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_cap_methods.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 diff --git a/config_src/drivers/mct_cap/ocn_comp_mct.F90 b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_comp_mct.F90 rename to config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 diff --git a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_cpl_indices.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 8ea0867d03..f91595bd51 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -24,7 +24,7 @@ program Shelf_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_debugging, only : MOM_debugging_init - use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var @@ -54,6 +54,8 @@ program Shelf_main use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_forcing_type, only : forcing + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf @@ -75,7 +77,9 @@ program Shelf_main ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to ! write_cputime. Initially it is set to be very large. integer :: nmax=2000000000 - + ! A structure containing pointers to the thermodynamic forcing fields + ! at the ocean surface. + type(forcing) :: fluxes ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -104,7 +108,7 @@ program Shelf_main real :: time_step ! The time step [T ~> s] ! A pointer to a structure containing metrics and related information. - type(ocean_grid_type), pointer :: ocn_grid + type(ocean_grid_type), pointer :: ocn_grid => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents @@ -114,7 +118,7 @@ program Shelf_main type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to a structure containing dimensional unit scaling factors. - type(unit_scale_type), pointer :: US + type(unit_scale_type), pointer :: US => NULL() type(diag_ctrl), pointer :: & diag => NULL() ! A pointer to the diagnostic regulatory structure @@ -138,8 +142,9 @@ program Shelf_main integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. + real :: smb !A constant surface mass balance that can be specified in the param_file character(len=9) :: month - character(len=16) :: calendar = 'julian' + character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 integer :: unit, io_status, ierr @@ -184,6 +189,8 @@ program Shelf_main endif endif + ! Get the names of the I/O directories and initialization file. + ! Also calls the subroutine that opens run-time parameter files. call Get_MOM_Input(param_file, dirs) ! Read ocean_solo restart, which can override settings from the namelist. @@ -252,8 +259,11 @@ program Shelf_main ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, ! but the grids have strong commonalities in this configuration, and the ocean grid is required ! to set up the diag mediator control structure. - call MOM_domains_init(ocn_grid%domain, param_file) + allocate(ocn_grid) + call MOM_domains_init(ocn_grid%domain, param_file) !, domain_name='MOM') + allocate(HI) call hor_index_init(ocn_grid%Domain, HI, param_file) + allocate(dG) call create_dyn_horgrid(dG, HI) call clone_MOM_domain(ocn_grid%Domain, dG%Domain) @@ -266,11 +276,16 @@ program Shelf_main ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. call verticalGridInit(param_file, GV, US) + allocate(diag) call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) call callTree_waypoint("returned from diag_mediator_init()") - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + call set_axes_info(ocn_grid, GV, US, param_file, diag) + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + + call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) ! This is the end of the code that is the counterpart of MOM_initialization. call callTree_waypoint("End of ice shelf initialization.") @@ -378,7 +393,7 @@ program Shelf_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time, fluxes_in=fluxes) ! Time = Time + Time_step_shelf ! This is here to enable fractional-second time steps. @@ -412,6 +427,20 @@ program Shelf_main if (BTEST(Restart_control,0)) then call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) endif + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif restart_time = restart_time + restint endif @@ -456,12 +485,11 @@ program Shelf_main endif call callTree_waypoint("End Shelf_main") + call ice_shelf_end(ice_shelf_CSp) call diag_mediator_end(Time, diag, end_diag_manager=.true.) if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end - call ice_shelf_end(ice_shelf_CSp) - end program Shelf_main diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 9db4f03100..a4b6f2ac69 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -28,9 +28,11 @@ module MOM_cap_mod use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose use MOM_cap_methods, only: ChkErr +use MOM_ensemble_manager, only: ensemble_manager_init #ifdef CESMCOUPLED use shr_log_mod, only: shr_log_setLogUnit +use nuopc_shr_methods, only: get_component_instance #endif use time_utils_mod, only: esmf2fms_time @@ -127,6 +129,7 @@ module MOM_cap_mod character(len=256) :: tmpstr logical :: write_diagnostics = .false. logical :: overwrite_timeslice = .false. +logical :: write_runtimelog = .false. character(len=32) :: runtype !< run type logical :: profile_memory = .true. logical :: grid_attach_area = .false. @@ -146,7 +149,9 @@ module MOM_cap_mod logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype #endif -character(len=8) :: restart_mode = 'alarms' +character(len=8) :: restart_mode = 'alarms' +character(len=16) :: inst_suffix = '' +real(8) :: timere contains @@ -230,6 +235,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) integer :: iostat character(len=64) :: value, logmsg character(len=*),parameter :: subname='(MOM_cap:InitializeP0)' + type(ESMF_VM) :: vm + integer :: mype rc = ESMF_SUCCESS @@ -247,6 +254,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) write_diagnostics call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + write_runtimelog = .false. + call NUOPC_CompAttributeGet(gcomp, name="RunTimeLog", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) write_runtimelog=(trim(value)=="true") + write(logmsg,*) write_runtimelog + call ESMF_LogWrite('MOM_cap:RunTimeLog = '//trim(logmsg), ESMF_LOGMSG_INFO) + overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -422,9 +437,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar + character(len=:), allocatable :: rpointer_filename + integer :: inst_index + real(8) :: MPI_Wtime, timeiads !-------------------------------- rc = ESMF_SUCCESS + if(write_runtimelog) timeiads = MPI_Wtime() call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) @@ -451,6 +470,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifdef CESMCOUPLED + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ensemble_manager_init(inst_suffix) + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) +#endif + ! reset shr logging to my log file if (localPet==0) then call NUOPC_CompAttributeGet(gcomp, name="diro", & @@ -460,11 +486,20 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) isPresent=isPresentLogfile, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (cesm_coupled) then + ! Multiinstance logfile name needs a correction + if(len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) + endif + endif + + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) else stdout = output_unit endif @@ -521,12 +556,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - - ! rsd need to figure out how to get this without share code - !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) - !inst_name = "OCN"//trim(inst_suffix) - - if (is_root_pe()) then write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif @@ -581,9 +610,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (localPet == 0) then ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat) if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening '//rpointer_filename, & line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif @@ -593,7 +622,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (len(trim(restartfiles))>1 .and. iostat<0) then exit ! done reading restart files list. else - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading '//rpointer_filename, & line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif @@ -616,7 +645,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + if (cesm_coupled .and. len_trim(inst_suffix)>0) then + call ocean_model_init(ocean_public, ocean_state, time0, time_start, & + input_restart_file=trim(adjustl(restartfiles)), inst_index=inst_index) + else + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + endif ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. call ocean_model_flux_init(ocean_state) @@ -774,7 +808,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo - if(is_root_pe()) write(stdout,*) 'InitializeAdvertise complete' + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeiads + end subroutine InitializeAdvertise !> Called by NUOPC to realize import and export fields. "Realizing" a field @@ -856,9 +891,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8) :: min_areacor_glob(2) real(ESMF_KIND_R8) :: max_areacor_glob(2) character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' + real(8) :: MPI_Wtime, timeirls !-------------------------------- rc = ESMF_SUCCESS + if(write_runtimelog) timeirls = MPI_Wtime() call shr_log_setLogUnit (stdout) @@ -1350,6 +1387,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! timeslice=1, relaxedFlag=.true., rc=rc) !if (ChkErr(rc,__LINE__,u_FILE_u)) return + timere = 0. + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls + end subroutine InitializeRealize !> TODO @@ -1378,8 +1418,11 @@ subroutine DataInitialize(gcomp, rc) type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) character(len=*),parameter :: subname='(MOM_cap:DataInitialize)' + real(8) :: MPI_Wtime, timedis !-------------------------------- + if(write_runtimelog) timedis = MPI_Wtime() + ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1440,6 +1483,8 @@ subroutine DataInitialize(gcomp, rc) enddo endif + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis + end subroutine DataInitialize !> Called by NUOPC to advance the model a single timestep. @@ -1489,10 +1534,16 @@ subroutine ModelAdvance(gcomp, rc) character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' character(len=8) :: suffix + character(len=:), allocatable :: rpointer_filename integer :: num_rest_files + real(8) :: MPI_Wtime, timers rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") + if(write_runtimelog) then + timers = MPI_Wtime() + if(timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere + endif call shr_log_setLogUnit (stdout) @@ -1658,6 +1709,8 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_VMGet(vm, localPet=localPet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & trim(casename), year, month, day, seconds call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) @@ -1665,13 +1718,17 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=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.ocn', form='formatted', status='unknown', iostat=iostat) + open(newunit=writeunit, 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.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) + msg=subname//' ERROR opening '//rpointer_filename, line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - write(writeunit,'(a)') trim(restartname)//'.nc' + if (len_trim(inst_suffix) == 0) then + write(writeunit,'(a)') trim(restartname)//'.nc' + else + write(writeunit,'(a)') trim(restartname)//'.'//trim(inst_suffix)//'.nc' + endif if (num_rest_files > 1) then ! append i.th restart file name to rpointer @@ -1726,6 +1783,11 @@ subroutine ModelAdvance(gcomp, rc) enddo endif + if(write_runtimelog) then + timere = MPI_Wtime() + if(is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers + endif + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") end subroutine ModelAdvance @@ -1928,11 +1990,13 @@ subroutine ocean_model_finalize(gcomp, rc) character(len=64) :: timestamp logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' + real(8) :: MPI_Wtime, timefs if (is_root_pe()) then write(stdout,*) 'MOM: --- finalize called ---' endif rc = ESMF_SUCCESS + if(write_runtimelog) timefs = MPI_Wtime() call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1961,9 +2025,7 @@ subroutine ocean_model_finalize(gcomp, rc) call io_infra_end() call MOM_infra_end() - if (is_root_pe()) then - write(stdout,*) 'MOM: --- completed ---' - endif + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs end subroutine ocean_model_finalize 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 9ee7ef921f..b4a9f1d604 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -41,7 +41,7 @@ module MOM_ocean_model_nuopc use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real use MOM_interpolate, only : time_interp_external_init -use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_flux_init, call_tracer_set_forcing use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -210,6 +210,8 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. + type(tracer_flow_control_CS), pointer :: & + tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(wave_parameters_CS), pointer, public :: & Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & @@ -226,7 +228,7 @@ module MOM_ocean_model_nuopc !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file, inst_index) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -243,6 +245,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + integer, optional :: inst_index !< Ensemble index provided by the cap (instead of FMS ensemble manager) ! Local variables real :: Rho0 ! The Boussinesq ocean density, in kg m-3. @@ -252,7 +255,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array - logical :: use_CFC !< If true, allocated arrays for surface CFCs. ! This include declares and sets the variable "version". @@ -280,7 +282,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i 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, & - diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) + diag_ptr=OS%diag, count_calls=.true., tracer_flow_CSp=OS%tracer_flow_CSp, & + waves_CSp=OS%Waves, ensemble_num=inst_index) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -373,8 +376,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i use_melt_pot=.false. endif - call get_param(param_file, mdl, "USE_CFC_CAP", use_CFC, & - default=.false., do_not_log=.true.) call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) @@ -382,7 +383,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_cfcs=use_CFC) + use_meltpot=use_melt_pot) 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) @@ -608,6 +609,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif + if (do_thermo) & + call call_tracer_set_forcing(OS%sfc_state, OS%fluxes, OS%Time, & + real_to_time_type(dt_coupling), OS%grid, OS%US, OS%GV%Rho0, & + OS%tracer_flow_CSp) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time 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 aee95ddd91..d699697140 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -27,7 +27,6 @@ module MOM_surface_forcing_nuopc use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init use MOM_interpolate, only : external_field -use MOM_CFC_cap, only : CFC_cap_fluxes use MOM_io, only : slasher, write_version_number, MOM_read_data use MOM_io, only : stdout use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS @@ -130,7 +129,6 @@ module MOM_surface_forcing_nuopc type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: CFC_BC_file !< filename with cfc11 and cfc12 data character(len=200) :: salt_restore_file !< filename for salt restoring data character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface @@ -144,18 +142,11 @@ module MOM_surface_forcing_nuopc !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - character(len=30) :: cfc11_var_name !< name of cfc11 in CFC_BC_file - character(len=30) :: cfc12_var_name !< name of cfc11 in CFC_BC_file real, pointer, dimension(:,:) :: trestore_mask => NULL() !< mask for SST restoring type(external_field) :: srestore_handle !< Handle for time-interpolated salt restoration field type(external_field) :: trestore_handle !< Handle for time-interpolated temperature restoration field - type(external_field) :: cfc11_atm_handle - !< Handle for time-interpolated CFC11 restoration field - type(external_field) :: cfc12_atm_handle - !< Handle for time-interpolated CFC12 restoration field - ! Diagnostics handles type(forcing_diags), public :: handles @@ -250,8 +241,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! local variables real, dimension(SZI_(G),SZJ_(G)) :: & - cfc11_atm, & !< CFC11 concentration in the atmopshere [???????] - cfc12_atm, & !< CFC11 concentration in the atmopshere [???????] data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] PmE_adj, & !< The adjustment to PminusE that will cause the salinity !! to be restored toward its target value [kg/(m^2 * s)] @@ -309,6 +298,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) + !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -599,12 +589,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif - ! CFCs - if (CS%use_CFC) then - call CFC_cap_fluxes(fluxes, sfc_state, G, US, CS%Rho0, Time, & - CS%cfc11_atm_handle, CS%cfc11_atm_handle) - endif - if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) @@ -720,6 +704,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + !call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) if (CS%rigid_sea_ice) then call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -880,6 +865,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) forces%tau_mag(i,j) = gustiness + G%mask2dT(i,j) * sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + !forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. @@ -1422,29 +1408,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, endif endif ; endif - ! Do not log these params here since they are logged in the CFC cap module - if (CS%use_CFC) then - call get_param(param_file, mdl, "CFC_BC_FILE", CS%CFC_BC_file, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ", do_not_log=.true.) - if ((len_trim(CS%CFC_BC_file) > 0) .and. (scan(CS%CFC_BC_file,'/') == 0)) then - ! Add the directory if CFC_BC_file is not already a complete path. - CS%CFC_BC_file = trim(CS%inputdir) // trim(CS%CFC_BC_file) - endif - if (len_trim(CS%CFC_BC_file) > 0) then - call get_param(param_file, mdl, "CFC11_VARIABLE", CS%cfc11_var_name, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11", do_not_log=.true.) - call get_param(param_file, mdl, "CFC12_VARIABLE", CS%cfc12_var_name, & - "The name of the variable representing CFC-12 in "//& - "CFC_BC_FILE.", default="CFC_12", do_not_log=.true.) - - CS%cfc11_atm_handle = init_external_field(CS%CFC_BC_file, CS%cfc11_var_name, domain=G%Domain%mpp_domain) - CS%cfc12_atm_handle = init_external_field(CS%CFC_BC_file, CS%cfc12_var_name, domain=G%Domain%mpp_domain) - endif - endif - ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") call restart_init_end(CS%restart_CSp) diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 84c2eec5b5..0e355f8638 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -49,6 +49,7 @@ program MOM6 use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : ice_shelf_query + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -134,7 +135,7 @@ program MOM6 real :: dtdia ! The diabatic timestep [T ~> s] real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] integer :: n, ns, n_max, nts, n_last_thermo - logical :: diabatic_first, single_step_call + logical :: diabatic_first, single_step_call, initialize_smb type(time_type) :: Time2, time_chg ! Temporary time variables integer :: Restart_control ! An integer that is bit-tested to determine whether @@ -302,6 +303,9 @@ program MOM6 call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) + call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & + initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) + if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) endif diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 274a815145..d17db5a9a1 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -352,7 +352,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) + call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, CS%Rho0, & + CS%tracer_flow_CSp) endif ! Allow for user-written code to alter the fluxes after all the above diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index fa3840c6c2..95470e6510 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -28,26 +28,32 @@ subroutine particles_init(parts, Grid, Time, dt, u, v, h) end subroutine particles_init !> The main driver the steps updates particles -subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) +subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [L T-1 ~>m s-1] - real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [L T-1~> m s-1] + real, dimension(:,:,:), intent(in) :: uo !< If use_uh is false, ocean zonal velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated zonal thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: vo !< If use_uh is false, ocean meridional velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated meridional thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + logical :: use_uh !< Flag for whether u and v are weighted by thickness integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts, h, temp, salt) +subroutine particles_save_restart(parts, h, directory, time, time_stamped) ! Arguments type(particles), pointer :: parts !< Container for all types and memory real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] + character(len=*), intent(in) :: directory !< The directory where the restart files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp to the restart file names end subroutine particles_save_restart diff --git a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..3ab9d591da 100644 --- a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 @@ -9,6 +9,7 @@ module MOM_ensemble_manager_infra use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +21,15 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..f4028f7af7 100644 --- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -9,6 +9,7 @@ module MOM_ensemble_manager_infra use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +21,15 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms2_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 392c603de6..bb890d2d87 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -360,6 +360,7 @@ module MOM !! higher values use more appropriate expressions that differ at !! roundoff for non-Boussinesq cases. logical :: use_particles !< Turns on the particles package + logical :: use_uh_particles !< particles are advected by uh/h logical :: use_dbclient !< Turns on the database client used for ML inference/analysis character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone. @@ -1266,10 +1267,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & enddo; enddo endif - if (CS%use_particles .and. CS%do_dynamics) then ! Run particles whether or not stepping is split - call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, CS%tv) ! Run the particles model - endif - if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then @@ -1331,6 +1328,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif call disable_averaging(CS%diag) + if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles) then + !Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%use_uh_particles) + elseif (CS%use_particles .and. CS%do_dynamics) then + !Run particles using unweighted velocity + call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & + CS%tv, CS%use_uh_particles) + endif + + ! Advance the dynamics time by dt. CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1 @@ -1950,7 +1958,7 @@ end subroutine step_offline !! initializing the ocean state variables, and initializing subsidiary modules subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp) + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse @@ -1970,8 +1978,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & !! dynamics timesteps. type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure type(Wave_parameters_CS), & - optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS - + optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS + !! ensemble manager) ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -2080,7 +2089,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Read paths and filenames from namelist and store in "dirs". ! Also open the parsed input parameter file(s) and setup param_file. - call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file) + call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file, ensemble_num=ensemble_num) verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) call MOM_set_verbosity(verbosity) @@ -2440,7 +2449,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, & "If true, use the particles package.", default=.false.) - + call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, & + "If true, use the uh velocity in the particles package.",default=.false.) CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & "If False, The model is being run in serial mode as a single realization. "//& @@ -4012,8 +4022,7 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) - ! TODO: Update particles to use Time and directories - if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index feb0b7e582..31f285c26f 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -67,10 +67,13 @@ module MOM_dynamics_split_RK2 use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS -use MOM_vert_friction, only : updateCFLtruncationValue +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member implicit none ; private @@ -136,6 +139,8 @@ module MOM_dynamics_split_RK2 real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] @@ -175,10 +180,11 @@ module MOM_dynamics_split_RK2 !! Euler (1) [nondim]. 0 is often used. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. !>@{ Diagnostic IDs + integer :: id_uold = -1, id_vold = -1 integer :: id_uh = -1, id_vh = -1 integer :: id_umo = -1, id_vmo = -1 integer :: id_umo_2d = -1, id_vmo_2d = -1 @@ -353,6 +359,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + ! GMM, TODO: make these allocatable? + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] real :: pres_to_eta ! A factor that converts pressures to the units of eta ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] real, pointer, dimension(:,:) :: & @@ -376,9 +387,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] - logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating @@ -388,7 +399,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s logical :: showCallTree, sym integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: cont_stencil + integer :: cont_stencil, obc_stencil is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -451,19 +462,23 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -676,11 +691,41 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = up(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = vp(i,J,k) + enddo + enddo + enddo + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC, VarMix) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + if (CS%fpmix) then + hbl(:,:) = 0.0 + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) @@ -899,10 +944,36 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = u(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = v(i,J,k) + enddo + enddo + enddo + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + + if (CS%fpmix) then + call vertFPmix(u, v, uold, vold, hbl, h, forces, dt, & + G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) @@ -983,6 +1054,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s CS%CAu_pred_stored = .false. endif + if (CS%fpmix) then + if (CS%id_uold > 0) call post_data(CS%id_uold , uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold , vold, CS%diag) + endif ! The time-averaged free surface height has already been set by the last call to btstep. @@ -1203,7 +1278,9 @@ subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, d if (CS%store_CAu) then call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) endif call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) @@ -1320,6 +1397,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param "If true, calculate the Coriolis accelerations at the end of each "//& "timestep for use in the predictor step of the next split RK2 timestep.", & default=.true.) + call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + "If true, apply profiles of momentum flux magnitude and "//& + " direction", default=.false.) call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& "variables that are needed to reproduce across restarts, similarly to "//& diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index f4e9960cd8..b5a17130e4 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -74,6 +74,7 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & + !omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. tau_mag => NULL(), & !< Magnitude of the wind stress averaged over tracer cells, !! including any contributions from sub-gridscale variability @@ -206,10 +207,8 @@ module MOM_forcing_type real :: C_p !< heat capacity of seawater [Q C-1 ~> J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. - ! CFC-related arrays needed in the MOM_CFC_cap module + ! arrays needed in the some tracer modules, e.g., MOM_CFC_cap real, pointer, dimension(:,:) :: & - cfc11_flux => NULL(), & !< flux of cfc_11 into the ocean [CU R Z T-1 ~> mol m-2 s-1] - cfc12_flux => NULL(), & !< flux of cfc_12 into the ocean [CU R Z T-1 ~> mol m-2 s-1] ice_fraction => NULL(), & !< fraction of sea ice coverage at h-cells, from 0 to 1 [nondim]. u10_sqr => NULL() !< wind magnitude at 10 m squared [L2 T-2 ~> m2 s-2] @@ -241,6 +240,8 @@ module MOM_forcing_type !! contributions from sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + !omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -376,15 +377,13 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 + !integer :: id_omega_w2x = -1 integer :: id_tau_mag = -1 - integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 integer :: id_buoy = -1 - ! cfc-related diagnostics handles - integer :: id_cfc11 = -1 - integer :: id_cfc12 = -1 + ! tracer surface flux related diagnostics handles integer :: id_ice_fraction = -1 integer :: id_u10_sqr = -1 @@ -1311,10 +1310,6 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) if (associated(fluxes%ice_fraction)) & call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) - if (associated(fluxes%cfc11_flux)) & - call hchksum(fluxes%cfc11_flux, mesg//" fluxes%cfc11_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) - if (associated(fluxes%cfc12_flux)) & - call hchksum(fluxes%cfc12_flux, mesg//" fluxes%cfc12_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%TKE_tidal)) & @@ -1510,6 +1505,9 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) + !handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + ! 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + if (present(use_berg_fluxes)) then if (use_berg_fluxes) then handles%id_ustar_berg = register_diag_field('ocean_model', 'ustar_berg', diag%axesT1, Time, & @@ -1529,26 +1527,9 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, endif endif - ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] ! See: - ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html - ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html if (present(use_cfcs)) then if (use_cfcs) then - handles%id_cfc11 = register_diag_field('ocean_model', 'cfc11_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC11 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc11', & - cmor_long_name='Surface Downward CFC11 Flux', & - cmor_standard_name='surface_downward_cfc11_flux') - - handles%id_cfc12 = register_diag_field('ocean_model', 'cfc12_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC12 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc12', & - cmor_long_name='Surface Downward CFC12 Flux', & - cmor_standard_name='surface_downward_cfc12_flux') - 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') @@ -2388,7 +2369,11 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif - + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) + ! enddo ; enddo + !endif if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = forces%tau_mag(i,j) @@ -2530,7 +2515,11 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) forces%ustar(i,j) = fluxes%ustar(i,j) enddo ; enddo endif - + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + ! enddo ; enddo + !endif if (associated(forces%tau_mag) .and. associated(fluxes%tau_mag)) then do j=js,je ; do i=is,ie forces%tau_mag(i,j) = fluxes%tau_mag(i,j) @@ -3154,13 +3143,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_netFWGlobalScl > 0) & call post_data(handles%id_netFWGlobalScl, fluxes%netFWGlobalScl, diag) - ! post diagnostics related to cfcs ==================================== - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc11_flux)) & - call post_data(handles%id_cfc11, fluxes%cfc11_flux, diag) - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc12_flux)) & - call post_data(handles%id_cfc12, fluxes%cfc12_flux, diag) + ! post diagnostics related to tracer surface fluxes ======================== if ((handles%id_ice_fraction > 0) .and. associated(fluxes%ice_fraction)) & call post_data(handles%id_ice_fraction, fluxes%ice_fraction, diag) @@ -3185,6 +3168,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) + !if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + ! call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -3225,7 +3211,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: salt !< If present and true, allocate salt fluxes logical, optional, intent(in) :: fix_accum_bug !< If present and true, avoid using a bug in !! accumulation of ustar_gustless - logical, optional, intent(in) :: cfc !< If present and true, allocate cfc fluxes + logical, optional, intent(in) :: cfc !< If present and true, allocate fields needed + !! for cfc surface fluxes logical, optional, intent(in) :: waves !< If present and true, allocate wave fields logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, !! then allocate surface flux deposition from the atmosphere @@ -3306,8 +3293,6 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) !These fields should only on allocated when USE_CFC_CAP is activated. - call myAlloc(fluxes%cfc11_flux,isd,ied,jsd,jed, cfc) - call myAlloc(fluxes%cfc12_flux,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, cfc) @@ -3523,6 +3508,7 @@ end subroutine myAlloc subroutine deallocate_forcing_type(fluxes) type(forcing), intent(inout) :: fluxes !< Forcing fields structure + !if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) if (associated(fluxes%ustar)) deallocate(fluxes%ustar) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) if (associated(fluxes%tau_mag)) deallocate(fluxes%tau_mag) @@ -3572,8 +3558,6 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%mass_berg)) deallocate(fluxes%mass_berg) if (associated(fluxes%ice_fraction)) deallocate(fluxes%ice_fraction) if (associated(fluxes%u10_sqr)) deallocate(fluxes%u10_sqr) - if (associated(fluxes%cfc11_flux)) deallocate(fluxes%cfc11_flux) - if (associated(fluxes%cfc12_flux)) deallocate(fluxes%cfc12_flux) call coupler_type_destructor(fluxes%tr_fluxes) @@ -3584,6 +3568,7 @@ end subroutine deallocate_forcing_type subroutine deallocate_mech_forcing(forces) type(mech_forcing), intent(inout) :: forces !< Forcing fields structure + !if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c995adb671..13ce524006 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,6 +9,7 @@ module MOM_open_boundary use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -373,6 +374,7 @@ module MOM_open_boundary !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + type(group_pass_type) :: pass_oblique !< Structure for group halo pass end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -1886,9 +1888,13 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & To_All+Scalar_Pair) if (OBC%oblique_BCs_exist_globally) then - call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call do_group_pass(OBC%pass_oblique, G%Domain) endif if (allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then do m=1,OBC%ntr @@ -5628,6 +5634,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) enddo endif enddo ; endif ; endif + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) then + call do_group_pass(OBC%pass_oblique, G%Domain) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + endif end subroutine remap_OBC_fields diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index fc307b9b2c..89383c4936 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -9,7 +9,7 @@ module MOM_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_random, only : random_unit_tests -use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests +use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests use MOM_EOS, only : EOS_unit_tests use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 8651daba55..0eab1a5b17 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -44,8 +44,6 @@ module MOM_variables SST, & !< The sea surface temperature [C ~> degC]. SSS, & !< The sea surface salinity [S ~> psu or gSalt/kg]. sfc_density, & !< The mixed layer density [R ~> kg m-3]. - sfc_cfc11, & !< Sea surface concentration of CFC11 [mol kg-1]. - sfc_cfc12, & !< Sea surface concentration of CFC12 [mol kg-1]. Hml, & !< The mixed layer depth [Z ~> m]. u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. @@ -339,7 +337,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, use_cfcs) + omit_frazil) 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. @@ -352,14 +350,13 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential - logical, optional, intent(in) :: use_cfcs !< If true, allocate the space for cfcs logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler ! local variables - logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil, alloc_cfcs + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -370,7 +367,6 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot - alloc_cfcs = .false. ; if (present(use_cfcs)) alloc_cfcs = use_cfcs alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil @@ -394,11 +390,6 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%melt_potential(isd:ied,jsd:jed), source=0.0) endif - if (alloc_cfcs) then - allocate(sfc_state%sfc_cfc11(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%sfc_cfc12(isd:ied,jsd:jed), source=0.0) - endif - if (alloc_integ) then ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, and ocean_salt. allocate(sfc_state%ocean_mass(isd:ied,jsd:jed), source=0.0) @@ -438,8 +429,6 @@ subroutine deallocate_surface_state(sfc_state) if (allocated(sfc_state%ocean_mass)) deallocate(sfc_state%ocean_mass) if (allocated(sfc_state%ocean_heat)) deallocate(sfc_state%ocean_heat) if (allocated(sfc_state%ocean_salt)) deallocate(sfc_state%ocean_salt) - if (allocated(sfc_state%sfc_cfc11)) deallocate(sfc_state%sfc_cfc11) - if (allocated(sfc_state%sfc_cfc12)) deallocate(sfc_state%sfc_cfc12) call coupler_type_destructor(sfc_state%tr_fields) sfc_state%arrays_allocated = .false. diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index b1f4444b1b..4a50abbb14 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -95,6 +95,8 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "FIRST_GUESS_SURFACE_LAYER_DEPTH") call obsolete_logical(param_file, "CORRECT_SURFACE_LAYER_AVERAGE") call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") + call obsolete_int(param_file, "USE_LATERAL_BOUNDARY_DIFFUSION", & + hint="Use USE_HORIZONTAL_BOUNDARY_DIFFUSION instead.") call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") call obsolete_logical(param_file, "USE_VISBECK_SLOPE_BUG", .false.) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 61290cb579..2c71a93e42 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3539,37 +3539,45 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) enddo call diag_grid_storage_end(diag_cs%diag_grid_temp) - deallocate(diag_cs%mask3dTL) - deallocate(diag_cs%mask3dBL) - deallocate(diag_cs%mask3dCuL) - deallocate(diag_cs%mask3dCvL) - deallocate(diag_cs%mask3dTi) - deallocate(diag_cs%mask3dBi) - deallocate(diag_cs%mask3dCui) - deallocate(diag_cs%mask3dCvi) + if (associated(diag_cs%mask3dTL)) deallocate(diag_cs%mask3dTL) + if (associated(diag_cs%mask3dBL)) deallocate(diag_cs%mask3dBL) + if (associated(diag_cs%mask3dCuL)) deallocate(diag_cs%mask3dCuL) + if (associated(diag_cs%mask3dCvL)) deallocate(diag_cs%mask3dCvL) + if (associated(diag_cs%mask3dTi)) deallocate(diag_cs%mask3dTi) + if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) + if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) + if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) do dl=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(dl)%mask2dT) - deallocate(diag_cs%dsamp(dl)%mask2dBu) - deallocate(diag_cs%dsamp(dl)%mask2dCu) - deallocate(diag_cs%dsamp(dl)%mask2dCv) - deallocate(diag_cs%dsamp(dl)%mask3dTL) - deallocate(diag_cs%dsamp(dl)%mask3dBL) - deallocate(diag_cs%dsamp(dl)%mask3dCuL) - deallocate(diag_cs%dsamp(dl)%mask3dCvL) - deallocate(diag_cs%dsamp(dl)%mask3dTi) - deallocate(diag_cs%dsamp(dl)%mask3dBi) - deallocate(diag_cs%dsamp(dl)%mask3dCui) - deallocate(diag_cs%dsamp(dl)%mask3dCvi) + if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) + if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) + if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) + if (associated(diag_cs%dsamp(dl)%mask2dCv)) deallocate(diag_cs%dsamp(dl)%mask2dCv) + if (associated(diag_cs%dsamp(dl)%mask3dTL)) deallocate(diag_cs%dsamp(dl)%mask3dTL) + if (associated(diag_cs%dsamp(dl)%mask3dBL)) deallocate(diag_cs%dsamp(dl)%mask3dBL) + if (associated(diag_cs%dsamp(dl)%mask3dCuL)) deallocate(diag_cs%dsamp(dl)%mask3dCuL) + if (associated(diag_cs%dsamp(dl)%mask3dCvL)) deallocate(diag_cs%dsamp(dl)%mask3dCvL) + if (associated(diag_cs%dsamp(dl)%mask3dTi)) deallocate(diag_cs%dsamp(dl)%mask3dTi) + if (associated(diag_cs%dsamp(dl)%mask3dBi)) deallocate(diag_cs%dsamp(dl)%mask3dBi) + if (associated(diag_cs%dsamp(dl)%mask3dCui)) deallocate(diag_cs%dsamp(dl)%mask3dCui) + if (associated(diag_cs%dsamp(dl)%mask3dCvi)) deallocate(diag_cs%dsamp(dl)%mask3dCvi) do i=1,diag_cs%num_diag_coords - deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) enddo enddo diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 88fabf0c74..944ccfdf07 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -124,7 +124,7 @@ module MOM_file_parser contains !> Make the contents of a parameter input file availalble in a param_file_type -subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) +subroutine open_param_file(filename, CS, checkable, component, doc_file_dir, ensemble_num) character(len=*), intent(in) :: filename !< An input file name, optionally with the full path type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters @@ -134,11 +134,13 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! to generate parameter documentation file names; the default is"MOM" character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out !! the documentation files. The default is effectively './'. + integer, optional, intent(in) :: ensemble_num !< ensemble number to be appended to _doc filenames (optional) ! Local variables logical :: file_exists, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path + character(len=5) :: ensemble_suffix type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -217,6 +219,11 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) call read_param(CS,"FATAL_UNUSED_PARAMS",CS%unused_params_fatal) CS%doc_file = "MOM_parameter_doc" + if (present(ensemble_num)) then + ! append instance suffix to doc_file + write(ensemble_suffix,'(A,I0.4)') '_', ensemble_num + CS%doc_file = trim(CS%doc_file)//ensemble_suffix + endif if (present(component)) CS%doc_file = trim(component)//"_parameter_doc" call read_param(CS,"DOCUMENT_FILE", CS%doc_file) if (.not.may_check) then diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index b6773ccb21..6ecc3ef3f9 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -115,7 +115,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, if (len_trim(trim(parameter_filename(io))) > 0) then if (present(ensemble_num)) then call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & - check_params, doc_file_dir=output_dir) + check_params, doc_file_dir=output_dir, ensemble_num=ensemble_num) else call open_param_file(ensembler(parameter_filename(io)), param_file, & check_params, doc_file_dir=output_dir) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index f5a85da95a..84858f17bc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -858,9 +858,9 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic endif enddo ; enddo - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt @@ -1660,7 +1660,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j)==3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1727,7 +1727,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1753,10 +1753,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) call cpu_clock_begin(id_clock_pass) - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%mass_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(G%bathyT, G%domain) call cpu_clock_end(id_clock_pass) @@ -1873,7 +1873,8 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) @@ -2031,7 +2032,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step < ISS%h_shelf(i,j)) then + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice < ISS%h_shelf(i,j)) then ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice else ! the ice is about to ablate, so set thickness, area, and mask to zero @@ -2100,10 +2101,10 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) CS%min_thickness_simple_calve, halo=0) endif - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) - call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) end subroutine update_shelf_mass @@ -2178,13 +2179,14 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in, fluxes_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors @@ -2192,6 +2194,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in !! the ice-shelf state real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] + real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. @@ -2205,6 +2208,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec remaining_time = US%s_to_T*time_type_to_real(time_interval) + full_time_step = remaining_time if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2228,6 +2232,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. @@ -2237,13 +2243,13 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - call enable_averages(time_step, Time, CS%diag) + enddo + + call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) - call disable_averaging(CS%diag) - - enddo + call disable_averaging(CS%diag) end subroutine solo_step_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index f4eacbb666..2965f6eac4 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -21,7 +21,7 @@ module MOM_ice_shelf_dynamics use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state -use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction @@ -98,11 +98,12 @@ module MOM_ice_shelf_dynamics !! the same as G%bathyT+Z_ref, when below sea-level. !! Sign convention: positive below sea-level, negative above. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" - !! basal stress (Pa) [R L2 T-2 ~> Pa]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field + !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part + !! of "linearized" basal stress (Pa) [R L3 T-1 ~> kg s-1] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), - !! units= Pa (m yr-1)-(n_basal_fric) + !! units= Pa (m s-1)^(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -144,6 +145,10 @@ module MOM_ice_shelf_dynamics real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] + logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) + real :: CF_MinN !< Minimum Coulomb friction effective pressure [R L2 T-2 ~> Pa] + real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] + real :: CF_Max !< Coulomb friction maximum coefficient [nondim] real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -277,7 +282,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] - allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) @@ -423,6 +428,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_COULOMB_FRICTION", CS%CoulombFriction, & + "Use Coulomb Friction Law", & + units="none", default=.false., fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & + "Minimum Coulomb friction effective pressure", & + units="Pa", default=1.0, scale=US%Pa_to_RL2_T2, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & + "Coulomb friction post peak exponent", & + units="none", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & + "Coulomb friction maximum coefficient", & + units="none", default=0.5, fail_if_missing=.false.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -533,20 +551,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif - call pass_var(CS%OD_av,G%domain) - call pass_var(CS%ground_frac,G%domain) - call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%basal_traction, G%domain) - call pass_var(CS%AGlen_visc, G%domain) - call pass_var(CS%bed_elev, G%domain) - call pass_var(CS%C_basal_friction, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac,G%domain, complete=.false.) + call pass_var(CS%ice_visc,G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif @@ -579,28 +597,28 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! initialize basal friction coefficients if (new_sim) then call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) - call pass_var(CS%C_basal_friction, G%domain) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) ! initialize ice-stiffness AGlen call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) - call pass_var(ISS%hmask, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & G, US, param_file) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%bed_elev, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif ! Register diagnostics. @@ -624,7 +642,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & - 'taub', 'MPa', conversion=1e-6*US%RL2_T2_to_Pa) + 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif @@ -685,7 +703,7 @@ function ice_time_step_CFL(CS, ISS, G) min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & @@ -720,7 +738,8 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged basal traction [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] integer :: iters logical :: update_ice_vel, coupled_GL @@ -749,18 +768,18 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled ! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - if (update_ice_vel) then + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) ! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) + taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudx_shelf, taud_x, CS%diag) endif if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) @@ -960,7 +979,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i nodefloat = 0 do l=0,1 ; do k=0,1 - if ((ISS%hmask(i,j) == 1) .and. & + if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then nodefloat = nodefloat + 1 endif @@ -971,7 +990,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif enddo ; enddo - call pass_var(float_cond, G%Domain) + call pass_var(float_cond, G%Domain, complete=.false.) call bilinear_shape_functions_subgrid(Phisub, nsub) @@ -985,9 +1004,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be @@ -1060,9 +1079,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call MOM_mesg(mesg, 5) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! makes sure basal stress is only applied when it is supposed to be @@ -1253,18 +1272,18 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu(:,:) = taudx(:,:) !- ubd(:,:) RHSv(:,:) = taudy(:,:) !- vbd(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) Ru(:,:) = (RHSu(:,:) - Au(:,:)) Rv(:,:) = (RHSv(:,:) - Av(:,:)) @@ -1326,12 +1345,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) endif enddo ; enddo @@ -1381,12 +1400,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) endif enddo ; enddo @@ -1424,9 +1443,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) cg_halo = 3 endif @@ -1493,7 +1512,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) - elseif ((hmask(i,j) == 1) .or. (hmask(i+1,j) == 1)) then + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1572,8 +1591,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) - elseif ((hmask(i,j) == 1) .or. (hmask(i,j+1) == 1)) then - + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1705,14 +1723,14 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1)) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell + if (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference = 0.0 tot_flux = 0.0 @@ -1720,7 +1738,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + h_reference = h_reference + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) tot_flux = tot_flux + flux_enter(i,j,k) flux_enter(i,j,k) = 0.0 endif @@ -1729,7 +1748,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + h_reference = h_reference + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) tot_flux = tot_flux + flux_enter(i,j,k+2) flux_enter(i,j,k+2) = 0.0 endif @@ -1737,11 +1757,12 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) if (n_flux > 0) then dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) + h_reference = h_reference / tot_flux + !h_reference = h_reference / real(n_flux) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference ISS%area_shelf_h(i,j) = G%areaT(i,j) elseif ((partial_vol / G%areaT(i,j)) < h_reference) then @@ -1751,7 +1772,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ISS%h_shelf(i,j) = h_reference else - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * G%areaT(i,j) @@ -1943,30 +1964,31 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) dyh = G%dyT(i,j) Dx=dxh Dy=dyh - if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then + ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx if ((i+i_off) == gisc) then ! at west computational bdry - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif elseif ((i+i_off) == giec) then ! at east computational bdry - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then sx = (S(i,j)-S(i-1,j))/dxh else sx = 0 endif else ! interior - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i+1,j) sx = S(i+1,j) else sx = S(i,j) endif - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i-1,j) sx = sx - S(i-1,j) @@ -1984,26 +2006,26 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! calculate sy, similarly if ((j+j_off) == gjsc) then ! at south computational bdry - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif elseif ((j+j_off) == gjec) then ! at north computational bdry - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then sy = (S(i,j)-S(i,j-1))/dyh else sy = 0 endif else ! interior - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then cnt = cnt+1 Dy =dyh+ G%dyT(i,j+1) sy = S(i,j+1) else sy = S(i,j) endif - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then cnt = cnt+1 sy = sy - S(i,j-1) Dy =dyh+ G%dyT(i,j-1) @@ -2198,8 +2220,8 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional @@ -2239,19 +2261,19 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, Ee=1.0 - do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then do iq=1,2 ; do jq=1,2 - uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - u_shlf(I,J) * xquad(iq) * xquad(jq) + uq = u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + u_shlf(I,J) * (xquad(iq) * xquad(jq)) - vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - v_shlf(I,J) * xquad(iq) * xquad(jq) + vq = v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + v_shlf(I,J) * (xquad(iq) * xquad(jq)) ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & @@ -2268,7 +2290,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & + vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) @@ -2287,9 +2309,9 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif enddo ; enddo enddo ; enddo @@ -2373,8 +2395,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are @@ -2407,7 +2429,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2533,8 +2555,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice @@ -2565,7 +2587,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -2581,15 +2603,15 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do iq=1,2 ; do jq=1,2 - uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) + uq = CS%u_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%u_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%u_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%u_bdry_val(I,J) * (xquad(iq) * xquad(jq)) - vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) + vq = CS%v_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%v_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%v_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%v_bdry_val(I,J) * (xquad(iq) * xquad(jq)) ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & @@ -2624,7 +2646,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) endif endif @@ -2635,7 +2657,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif endif enddo ; enddo @@ -2814,6 +2836,10 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + real :: alpha !Coulomb coefficient [nondim] + real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] + real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R L2 T-2 ~> Pa] + real :: fB !for Coulomb Friction [(L T-1)^CS%CF_PostPeak ~> (m s-1)^CS%CF_PostPeak] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2825,15 +2851,34 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) eps_min = CS%eps_glen_min + if (CS%CoulombFriction) then + if (CS%CF_PostPeak.ne.1.0) THEN + alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + else + alpha = 1.0 + endif + endif do j=jsd+1,jed do i=isd+1,ied if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) -! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + unorm = US%L_T_to_m_s*sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max(CS%density_ocean_avg * CS%bed_elev(i,j)/CS%density_ice, 0.0) + fN = max(CS%density_ice * CS%g_Earth * (ISS%h_shelf(i,j) - Hf),CS%CF_MinN) + + fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * & + unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric) + else + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric .ne. 1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * unorm**(CS%n_basal_fric-1) + endif endif enddo enddo @@ -2874,8 +2919,8 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 enddo ; enddo - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%OD_av, G%domain) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%OD_av, G%domain, complete=.true.) endif end subroutine update_OD_ffrac @@ -2947,8 +2992,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) do node=1,4 @@ -3179,7 +3224,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face endif do j=js,G%jed; do i=is,G%ied - if (hmask(i,j) == 1) then + if (hmask(i,j) == 1 .or. hmask(i,j)==3) then umask(I-1:I,J-1:J)=1 vmask(I-1:I,J-1:J)=1 endif @@ -3320,7 +3365,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) num_h = 0 do k=0,1 do l=0,1 - if (hmask(i+k,j+l) == 1.0) then + if (hmask(i+k,j+l) == 1.0 .or. hmask(i+k,j+l) == 3.0) then summ = summ + h_shelf(i+k,j+l) num_h = num_h + 1 endif @@ -3438,8 +3483,8 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) endif enddo ; enddo - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) + call pass_var(CS%t_shelf, G%domain, complete=.false.) + call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 20a48730f3..1e2076f889 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -22,6 +22,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction public initialize_ice_AGlen +public initialize_ice_SMB ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with ! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units @@ -657,5 +658,51 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call MOM_read_data(filename,trim(varname), AGlen, G%Domain) endif -end subroutine +end subroutine initialize_ice_AGlen + +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(SMB, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname), SMB, G%Domain) + + endif +end subroutine initialize_ice_SMB end module MOM_ice_shelf_initialize diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 32413ad2d8..8b66f35f48 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -31,8 +31,8 @@ module MOM_ice_shelf_state !! ice-covered cells are treated the same, this may change) !! 2: partially covered, do not solve for velocity !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in computational domain - !! -2 : default (out of computational boundary, and) not = 3 + !! 3: bdry condition on thickness set + !! -2 : default (out of computational boundary) !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED !! otherwise the wrong nodes will be included in velocity calcs. diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 500e4a508c..b49d123377 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -1,23 +1,26 @@ -! > Calculates Zanna and Bolton 2020 parameterization +!> Calculates Zanna and Bolton 2020 parameterization +!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com module MOM_Zanna_Bolton +! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type use MOM_verticalGrid, only : verticalGrid_type use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_unit_scaling, only : unit_scale_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type, & + start_group_pass, complete_group_pass use MOM_domains, only : To_North, To_East use MOM_domains, only : pass_var, CORNER -use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs -use MOM_error_handler, only : MOM_error, WARNING +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE implicit none ; private #include -public Zanna_Bolton_2020, ZB_2020_init +public ZB2020_lateral_stress, ZB2020_init, ZB2020_end, ZB2020_copy_gradient_and_thickness !> Control structure for Zanna-Bolton-2020 parameterization. type, public :: ZB2020_CS ; private @@ -31,50 +34,86 @@ module MOM_Zanna_Bolton integer :: ZB_cons !< Select a discretization scheme for ZB model !! 0 - non-conservative scheme !! 1 - conservative scheme for deviatoric component - integer :: LPF_iter !< Number of smoothing passes for the Velocity Gradient (VG) components - !! in ZB model. - integer :: LPF_order !< The scale selectivity of the smoothing filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter integer :: HPF_iter !< Number of sharpening passes for the Velocity Gradient (VG) components !! in ZB model. - integer :: HPF_order !< The scale selectivity of the sharpening filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter integer :: Stress_iter !< Number of smoothing passes for the Stress tensor components !! in ZB model. - integer :: Stress_order !< The scale selectivity of the smoothing filter - !! 1 - Laplacian filter - !! 2 - Bilaplacian filter - integer :: ssd_iter !< Hyperviscosity parameter. Defines the number of sharpening passes - !! in Laplacian viscosity model: - !! -1: hyperviscosity is off - !! 0: Laplacian viscosity - !! 9: (Laplacian)^10 viscosity, ... - real :: ssd_bound_coef !< The non-dimensional damping coefficient of the grid harmonic - !! by hyperviscous dissipation: - !! 0.0: no damping - !! 1.0: grid harmonic is removed after a step in time - real :: DT !< The (baroclinic) dynamics time step [T ~> s] + real :: Klower_R_diss !< Attenuation of + !! the ZB parameterization in the regions of + !! geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019) + !! Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))) + !! R_diss=-1: attenuation is not used; typical value R_diss=1.0 [nondim] + integer :: Klower_shear !< Type of expression for shear in Klower formula + !! 0: sqrt(sh_xx**2 + sh_xy**2) + !! 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + integer :: Marching_halo !< The number of filter iterations per a single MPI + !! exchange + + real, dimension(:,:,:), allocatable :: & + sh_xx, & !< Horizontal tension (du/dx - dv/dy) in h (CENTER) + !! points including metric terms [T-1 ~> s-1] + sh_xy, & !< Horizontal shearing strain (du/dy + dv/dx) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + vort_xy, & !< Vertical vorticity (dv/dx - du/dy) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + hq !< Thickness in CORNER points [H ~> m or kg m-2] + + real, dimension(:,:,:), allocatable :: & + Txx, & !< Subgrid stress xx component in h [L2 T-2 ~> m2 s-2] + Tyy, & !< Subgrid stress yy component in h [L2 T-2 ~> m2 s-2] + Txy !< Subgrid stress xy component in q [L2 T-2 ~> m2 s-2] + + real, dimension(:,:), allocatable :: & + kappa_h, & !< Scaling coefficient in h points [L2 ~> m2] + kappa_q !< Scaling coefficient in q points [L2 ~> m2] + + real, allocatable :: & + ICoriolis_h(:,:), & !< Inverse Coriolis parameter at h points [T ~> s] + c_diss(:,:,:) !< Attenuation parameter at h points + !! (Klower 2018, Juricke2019,2020) [nondim] + + real, dimension(:,:), allocatable :: & + maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] + maskw_q !< Same mask but for q points [nondim] type(diag_ctrl), pointer :: diag => NULL() !< A type that regulates diagnostics output !>@{ Diagnostic handles integer :: id_ZB2020u = -1, id_ZB2020v = -1, id_KE_ZB2020 = -1 - integer :: id_maskT = -1 - integer :: id_maskq = -1 - integer :: id_S_11 = -1 - integer :: id_S_22 = -1 - integer :: id_S_12 = -1 + integer :: id_Txx = -1 + integer :: id_Tyy = -1 + integer :: id_Txy = -1 + integer :: id_cdiss = -1 + !>@} + + !>@{ CPU time clock IDs + integer :: id_clock_module + integer :: id_clock_copy + integer :: id_clock_cdiss + integer :: id_clock_stress + integer :: id_clock_divergence + integer :: id_clock_mpi + integer :: id_clock_filter + integer :: id_clock_post + integer :: id_clock_source + !>@} + + !>@{ MPI group passes + type(group_pass_type) :: & + pass_Tq, pass_Th, & !< handles for halo passes of Txy and Txx, Tyy + pass_xx, pass_xy !< handles for halo passes of sh_xx and sh_xy, vort_xy + integer :: Stress_halo = -1, & !< The halo size in filter of the stress tensor + HPF_halo = -1 !< The halo size in filter of the velocity gradient !>@} end type ZB2020_CS contains -!> Read parameters and register output fields -!! used in Zanna_Bolton_2020(). -subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) +!> Read parameters, allocate and precompute arrays, +!! register diagnosicts used in Zanna_Bolton_2020(). +subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) type(time_type), intent(in) :: Time !< The current model time. + 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(param_file_type), intent(in) :: param_file !< Parameter file parser structure. @@ -82,10 +121,19 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. + real :: subroundoff_Cor ! A negligible parameter which avoids division by zero + ! but small compared to Coriolis parameter [T-1 ~> s-1] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & @@ -95,7 +143,7 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) call get_param(param_file, mdl, "ZB_SCALING", CS%amplitude, & "The nondimensional scaling factor in ZB model, " //& - "typically 0.1 - 10.", units="nondim", default=0.3) + "typically 0.5-2.5", units="nondim", default=0.5) call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & "Select how to compute the trace part of ZB model:\n" //& @@ -108,59 +156,31 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) "\t 0 - non-conservative scheme\n" //& "\t 1 - conservative scheme for deviatoric component", default=1) - call get_param(param_file, mdl, "VG_SMOOTH_PASS", CS%LPF_iter, & - "Number of smoothing passes for the Velocity Gradient (VG) components " //& - "in ZB model.", default=0) - - call get_param(param_file, mdl, "VG_SMOOTH_SEL", CS%LPF_order, & - "The scale selectivity of the smoothing filter " //& - "for VG components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter, ...", & - default=1, do_not_log = CS%LPF_iter==0) - call get_param(param_file, mdl, "VG_SHARP_PASS", CS%HPF_iter, & "Number of sharpening passes for the Velocity Gradient (VG) components " //& "in ZB model.", default=0) - call get_param(param_file, mdl, "VG_SHARP_SEL", CS%HPF_order, & - "The scale selectivity of the sharpening filter " //& - "for VG components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter,...", & - default=1, do_not_log = CS%HPF_iter==0) - call get_param(param_file, mdl, "STRESS_SMOOTH_PASS", CS%Stress_iter, & "Number of smoothing passes for the Stress tensor components " //& "in ZB model.", default=0) - call get_param(param_file, mdl, "STRESS_SMOOTH_SEL", CS%Stress_order, & - "The scale selectivity of the smoothing filter " //& - "for the Stress tensor components:\n" //& - "\t 1 - Laplacian filter\n" //& - "\t 2 - Bilaplacian filter,...", & - default=1, do_not_log = CS%Stress_iter==0) - - call get_param(param_file, mdl, "ZB_HYPERVISC", CS%ssd_iter, & - "Select an additional hyperviscosity to stabilize the ZB model:\n" //& - "\t 0 - off\n" //& - "\t 1 - Laplacian viscosity\n" //& - "\t 10 - (Laplacian)**10 viscosity, ...", & - default=0) - ! Convert to the number of sharpening passes - ! applied to the Laplacian viscosity model - CS%ssd_iter = CS%ssd_iter-1 - - call get_param(param_file, mdl, "HYPVISC_GRID_DAMP", CS%ssd_bound_coef, & - "The non-dimensional damping coefficient of the grid harmonic " //& - "by hyperviscous dissipation:\n" //& - "\t 0.0 - no damping\n" //& - "\t 1.0 - grid harmonic is removed after a step in time", & - units="nondim", default=0.2, do_not_log = CS%ssd_iter==-1) - - call get_param(param_file, mdl, "DT", CS%dt, & - "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & - fail_if_missing=.true.) + call get_param(param_file, mdl, "ZB_KLOWER_R_DISS", CS%Klower_R_diss, & + "Attenuation of " //& + "the ZB parameterization in the regions of " //& + "geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019). " //& + "Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))):\n" //& + "\t R_diss=-1. - attenuation is not used\n\t R_diss= 1. - typical value", & + units="nondim", default=-1.) + + call get_param(param_file, mdl, "ZB_KLOWER_SHEAR", CS%Klower_shear, & + "Type of expression for shear in Klower formula:\n" //& + "\t 0: sqrt(sh_xx**2 + sh_xy**2)\n" //& + "\t 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)", & + default=1, do_not_log=.not.CS%Klower_R_diss>0) + + call get_param(param_file, mdl, "ZB_MARCHING_HALO", CS%Marching_halo, & + "The number of filter iterations per single MPI " //& + "exchange", default=4, do_not_log=(CS%Stress_iter==0).and.(CS%HPF_iter==0)) ! Register fields for output from this module. CS%diag => diag @@ -173,726 +193,832 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) 'Kinetic Energy Source from Horizontal Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) - CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & - 'Mask of wet points in T (CENTER) points', '1', conversion=1.) + CS%id_Txx = register_diag_field('ocean_model', 'Txx', diag%axesTL, Time, & + 'Diagonal term (Txx) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Tyy = register_diag_field('ocean_model', 'Tyy', diag%axesTL, Time, & + 'Diagonal term (Tyy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Txy = register_diag_field('ocean_model', 'Txy', diag%axesBL, Time, & + 'Off-diagonal term (Txy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + if (CS%Klower_R_diss > 0) then + CS%id_cdiss = register_diag_field('ocean_model', 'c_diss', diag%axesTL, Time, & + 'Klower (2018) attenuation coefficient', 'nondim') + endif + + ! Clock IDs + ! Only module is measured with syncronization. While smaller + ! parts are measured without - because these are nested clocks. + CS%id_clock_module = cpu_clock_id('(Ocean Zanna-Bolton-2020)', grain=CLOCK_MODULE) + CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + + ! Allocate memory + ! We set the stress tensor and velocity gradient tensor to zero + ! with full halo because they potentially may be filtered + ! with marching halo algorithm + allocate(CS%sh_xx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%sh_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%vort_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%hq(SZIB_(G),SZJB_(G),SZK_(GV))) + + allocate(CS%Txx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Tyy(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Txy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%kappa_h(SZI_(G),SZJ_(G))) + allocate(CS%kappa_q(SZIB_(G),SZJB_(G))) + + ! Precomputing the scaling coefficient + ! Mask is included to automatically satisfy B.C. + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) + enddo; enddo + + if (CS%Klower_R_diss > 0) then + allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) + allocate(CS%c_diss(SZI_(G),SZJ_(G),SZK_(GV))) + + subroundoff_Cor = 1e-30 * US%T_to_s + ! Precomputing 1/(f * R_diss) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) & + * CS%Klower_R_diss) + enddo; enddo + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + ! Include 1/16. factor to the mask for filter implementation + allocate(CS%maskw_h(SZI_(G),SZJ_(G))); CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625 + allocate(CS%maskw_q(SZIB_(G),SZJB_(G))); CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625 + endif + + ! Initialize MPI group passes + if (CS%Stress_iter > 0) then + ! reduce size of halo exchange accordingly to + ! Marching halo, number of iterations and the array size + ! But let exchange width be at least 1 + CS%Stress_halo = max(min(CS%Marching_halo, CS%Stress_iter, & + G%Domain%nihalo, G%Domain%njhalo), 1) + + call create_group_pass(CS%pass_Tq, CS%Txy, G%Domain, halo=CS%Stress_halo, & + position=CORNER) + call create_group_pass(CS%pass_Th, CS%Txx, G%Domain, halo=CS%Stress_halo) + call create_group_pass(CS%pass_Th, CS%Tyy, G%Domain, halo=CS%Stress_halo) + endif + + if (CS%HPF_iter > 0) then + ! The minimum halo size is 2 because it is requirement for the + ! outputs of function filter_velocity_gradients + CS%HPF_halo = max(min(CS%Marching_halo, CS%HPF_iter, & + G%Domain%nihalo, G%Domain%njhalo), 2) + + call create_group_pass(CS%pass_xx, CS%sh_xx, G%Domain, halo=CS%HPF_halo) + call create_group_pass(CS%pass_xy, CS%sh_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + call create_group_pass(CS%pass_xy, CS%vort_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + endif + +end subroutine ZB2020_init - CS%id_maskq = register_diag_field('ocean_model', 'maskq', diag%axesBL, Time, & - 'Mask of wet points in q (CORNER) points', '1', conversion=1.) +!> Deallocate any variables allocated in ZB_2020_init +subroutine ZB2020_end(CS) + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! action of filter on momentum flux - CS%id_S_11 = register_diag_field('ocean_model', 'S_11', diag%axesTL, Time, & - 'Diagonal term (11) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + deallocate(CS%sh_xx) + deallocate(CS%sh_xy) + deallocate(CS%vort_xy) + deallocate(CS%hq) - CS%id_S_22 = register_diag_field('ocean_model', 'S_22', diag%axesTL, Time, & - 'Diagonal term (22) in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + deallocate(CS%Txx) + deallocate(CS%Tyy) + deallocate(CS%Txy) + deallocate(CS%kappa_h) + deallocate(CS%kappa_q) - CS%id_S_12 = register_diag_field('ocean_model', 'S_12', diag%axesBL, Time, & - 'Off-diagonal term in the ZB stress tensor', 'm2s-2', conversion=US%L_T_to_m_s**2) + if (CS%Klower_R_diss > 0) then + deallocate(CS%ICoriolis_h) + deallocate(CS%c_diss) + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + deallocate(CS%maskw_h) + deallocate(CS%maskw_q) + endif + +end subroutine ZB2020_end + +!> Save precomputed velocity gradients and thickness +!! from the horizontal eddy viscosity module +!! We save as much halo for velocity gradients as possible +!! In symmetric (preferable) memory model: halo 2 for sh_xx +!! and halo 1 for sh_xy and vort_xy +!! We apply zero boundary conditions to velocity gradients +!! which is required for filtering operations +subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, & + G, GV, CS, k) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: hq !< harmonic mean of the harmonic means + !! of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) + !! including metric terms [T-1 ~> s-1] + + integer, intent(in) :: k !< The vertical index of the layer to be passed. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(CS%id_clock_copy) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%hq(I,J,k) = hq(I,J) + enddo; enddo + + ! No physical B.C. is required for + ! sh_xx in ZB2020. However, filtering + ! may require BC + do j=Jsq-1,je+2 ; do i=Isq-1,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j) * G%mask2dT(i,j) + enddo ; enddo + + ! We multiply by mask to remove + ! implicit dependence on CS%no_slip + ! flag in hor_visc module + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo + + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo -end subroutine ZB_2020_init + call cpu_clock_end(CS%id_clock_copy) + +end subroutine ZB2020_copy_gradient_and_thickness !> Baroclinic Zanna-Bolton-2020 parameterization, see !! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf -!! We collect all contributions to a tensor S, with components: -!! (S_11, S_12; -!! S_12, S_22) -!! Which consists of the deviatoric and trace components, respectively: -!! S = (-vort_xy * sh_xy, vort_xy * sh_xx; -!! vort_xy * sh_xx, vort_xy * sh_xy) + -!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; -!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) -!! Where: -!! vort_xy = dv/dx - du/dy - relative vorticity -!! sh_xy = dv/dx + du/dy - shearing deformation (or horizontal shear strain) -!! sh_xx = du/dx - dv/dy - stretching deformation (or horizontal tension) -!! Update of the governing equations: -!! (du/dt, dv/dt) = k_BC * div(S) -!! Where: -!! k_BC = - amplitude * grid_cell_area -!! amplitude = 0.1..10 (approx) - -subroutine Zanna_Bolton_2020(u, v, h, fx, fy, G, GV, CS) - 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(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. +!! We compute the lateral stress tensor according to ZB2020 model +!! and update the acceleration due to eddy viscosity (diffu, diffv) +!! as follows: +!! diffu = diffu + ZB2020u +!! diffv = diffv + ZB2020v +subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & + dx2h, dy2h, dx2q, dy2q) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: fx !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor [L T-2 ~> m s-2] + intent(inout) :: diffu !< Zonal acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(out) :: fy !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor [L T-2 ~> m s-2] - - ! Arrays defined in h (CENTER) points - real, dimension(SZI_(G),SZJ_(G)) :: & - dx_dyT, & ! dx/dy at h points [nondim] - dy_dxT, & ! dy/dx at h points [nondim] - dx2h, & ! dx^2 at h points [L2 ~> m2] - dy2h, & ! dy^2 at h points [L2 ~> m2] - dudx, dvdy, & ! Components in the horizontal tension [T-1 ~> s-1] - sh_xx, & ! Horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - vort_xy_center, & ! Vorticity interpolated to the center [T-1 ~> s-1] - sh_xy_center, & ! Shearing strain interpolated to the center [T-1 ~> s-1] - S_11, S_22, & ! Diagonal terms in the ZB stress tensor: - ! Above Line 539 [L2 T-2 ~> m2 s-2] - ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] - ssd_11, & ! Diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] - ssd_11_coef, & ! Viscosity coefficient in hyperviscous stress in center points - ! [L2 T-1 ~> m2 s-1] - mask_T ! Mask of wet points in T (CENTER) points [nondim] - - ! Arrays defined in q (CORNER) points - real, dimension(SZIB_(G),SZJB_(G)) :: & - dx_dyBu, & ! dx/dy at q points [nondim] - dy_dxBu, & ! dy/dx at q points [nondim] - dx2q, & ! dx^2 at q points [L2 ~> m2] - dy2q, & ! dy^2 at q points [L2 ~> m2] - dvdx, dudy, & ! Components in the shearing strain [T-1 ~> s-1] - vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] - sh_xy, & ! Horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] - sh_xx_corner, & ! Horizontal tension interpolated to the corner [T-1 ~> s-1] - S_12, & ! Off-diagonal term in the ZB stress tensor: - ! Above Line 539 [L2 T-2 ~> m2 s-2] - ! Below Line 539 it is layer-integrated [H L2 T-2 ~> m3 s-2 or kg s-2] - ssd_12, & ! Off-diagonal component of hyperviscous stress [L2 T-2 ~> m2 s-2] - ssd_12_coef, & ! Viscosity coefficient in hyperviscous stress in corner points - ! [L2 T-1 ~> m2 s-1] - mask_q ! Mask of wet points in q (CORNER) points [nondim] - - ! Thickness arrays for computing the horizontal divergence of the stress tensor - real, dimension(SZIB_(G),SZJB_(G)) :: & - hq ! Thickness in CORNER points [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G)) :: & - h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJB_(G)) :: & - h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. - - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - mask_T_3d, & ! Mask of wet points in T (CENTER) points [nondim] - S_11_3d, S_22_3d ! Diagonal terms in the ZB stress tensor [L2 T-2 ~> m2 s-2] + intent(inout) :: diffv !< Meridional acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] - real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & - mask_q_3d, & ! Mask of wet points in q (CORNER) points [nondim] - S_12_3d ! Off-diagonal term in the ZB stress tensor [L2 T-2 ~> m2 s-2] - - real :: h_neglect ! Thickness so small it can be lost in roundoff and so neglected [H ~> m or kg m-2] - real :: h_neglect3 ! h_neglect^3 [H3 ~> m3 or kg3 m-6] - real :: h2uq, h2vq ! Temporary variables [H2 ~> m2 or kg2 m-4]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] - real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) [T-2 ~> s-2] - real :: vort_sh ! vort_xy*sh_xy [T-2 ~> s-2] - - real :: k_bc ! Constant in from of the parameterization [L2 ~> m2] - ! Related to the amplitude as follows: - ! k_bc = - amplitude * grid_cell_area < 0 + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - ! Line 407 of MOM_hor_visc.F90 + call cpu_clock_begin(CS%id_clock_module) + 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 - h_neglect = GV%H_subroundoff ! Line 410 on MOM_hor_visc.F90 - h_neglect3 = h_neglect**3 + ! Compute attenuation if specified + call compute_c_diss(G, GV, CS) - fx(:,:,:) = 0. - fy(:,:,:) = 0. + ! Sharpen velocity gradients if specified + call filter_velocity_gradients(G, GV, CS) - ! Calculate metric terms (line 2119 of MOM_hor_visc.F90) - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) - DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) - enddo ; enddo + ! Compute the stress tensor given the + ! (optionally sharpened) velocity gradients + call compute_stress(G, GV, CS) - ! Calculate metric terms (line 2122 of MOM_hor_visc.F90) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) - DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) - enddo ; enddo + ! Smooth the stress tensor if specified + call filter_stress(G, GV, CS) - if (CS%ssd_iter > -1) then - ssd_11_coef(:,:) = 0. - ssd_12_coef(:,:) = 0. - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - ssd_11_coef(i,j) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & - * ((dx2h(i,j) * dy2h(i,j)) / (dx2h(i,j) + dy2h(i,j))) - enddo; enddo + ! Update the acceleration due to eddy viscosity (diffu, diffv) + ! with the ZB2020 lateral parameterization + call compute_stress_divergence(u, v, h, diffu, diffv, & + dx2h, dy2h, dx2q, dy2q, & + G, GV, CS) - do J=js-1,Jeq ; do I=is-1,Ieq - ssd_12_coef(I,J) = ((CS%ssd_bound_coef * 0.25) / CS%DT) & - * ((dx2q(I,J) * dy2q(I,J)) / (dx2q(I,J) + dy2q(I,J))) - enddo; enddo - endif + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_Txx>0) call post_data(CS%id_Txx, CS%Txx, CS%diag) + if (CS%id_Tyy>0) call post_data(CS%id_Tyy, CS%Tyy, CS%diag) + if (CS%id_Txy>0) call post_data(CS%id_Txy, CS%Txy, CS%diag) - do k=1,nz + if (CS%id_cdiss>0) call post_data(CS%id_cdiss, CS%c_diss, CS%diag) + call cpu_clock_end(CS%id_clock_post) - sh_xx(:,:) = 0. - sh_xy(:,:) = 0. - vort_xy(:,:) = 0. - S_12(:,:) = 0. - S_11(:,:) = 0. - S_22(:,:) = 0. - ssd_11(:,:) = 0. - ssd_12(:,:) = 0. - - ! Calculate horizontal tension (line 590 of MOM_hor_visc.F90) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dudx(i,j) = DY_dxT(i,j)*(G%IdyCu(I,j) * u(I,j,k) - & - G%IdyCu(I-1,j) * u(I-1,j,k)) - dvdy(i,j) = DX_dyT(i,j)*(G%IdxCv(i,J) * v(i,J,k) - & - G%IdxCv(i,J-1) * v(i,J-1,k)) - sh_xx(i,j) = dudx(i,j) - dvdy(i,j) ! center of the cell - enddo ; enddo + call cpu_clock_end(CS%id_clock_module) - ! Components for the shearing strain (line 599 of MOM_hor_visc.F90) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - dvdx(I,J) = DY_dxBu(I,J)*(v(i+1,J,k)*G%IdyCv(i+1,J) - v(i,J,k)*G%IdyCv(i,J)) - dudy(I,J) = DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) - enddo ; enddo +end subroutine ZB2020_lateral_stress - ! Shearing strain with free-slip B.C. (line 751 of MOM_hor_visc.F90) - ! We use free-slip as cannot guarantee that non-diagonal stress - ! will accelerate or decelerate currents - ! Note that as there is no stencil operator, set of indices - ! is identical to the previous loop, compared to MOM_hor_visc.F90 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - sh_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) + dudy(I,J) ) ! corner of the cell - enddo ; enddo +!> Compute the attenuation parameter similarly +!! to Klower2018, Juricke2019,2020: c_diss = 1/(1+(shear/(f*R_diss))) +!! where shear = sqrt(sh_xx**2 + sh_xy**2) or shear = sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) +!! In symmetric memory model, components of velocity gradient tensor +!! should have halo 1 and zero boundary conditions. The result: c_diss having halo 1. +subroutine compute_c_diss(G, GV, CS) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! Relative vorticity with free-slip B.C. (line 789 of MOM_hor_visc.F90) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) ! corner of the cell - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - call compute_masks(G, GV, h, mask_T, mask_q, k) - if (CS%id_maskT>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - mask_T_3d(i,j,k) = mask_T(i,j) - enddo; enddo - endif + real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1] - if (CS%id_maskq>0) then - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - mask_q_3d(i,j,k) = mask_q(i,j) - enddo; enddo - endif + if (.not. CS%Klower_R_diss > 0) & + return - ! Numerical scheme for ZB2020 requires - ! interpolation center <-> corner - ! This interpolation requires B.C., - ! and that is why B.C. for Velocity Gradients should be - ! well defined - ! The same B.C. will be used by all filtering operators - do J=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+2 - sh_xx(i,j) = sh_xx(i,j) * mask_T(i,j) - enddo ; enddo + call cpu_clock_begin(CS%id_clock_cdiss) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - sh_xy(i,j) = sh_xy(i,j) * mask_q(i,j) - vort_xy(i,j) = vort_xy(i,j) * mask_q(i,j) - enddo ; enddo + 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%ssd_iter > -1) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - ssd_11(i,j) = sh_xx(i,j) * ssd_11_coef(i,j) - enddo; enddo + do k=1,nz - do J=js-1,Jeq ; do I=is-1,Ieq - ssd_12(I,J) = sh_xy(I,J) * ssd_12_coef(I,J) + ! sqrt(sh_xx**2 + sh_xy**2) + if (CS%Klower_shear == 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + (CS%sh_xy(I-1,J-1,k)**2 + CS%sh_xy(I,J ,k)**2) & + + (CS%sh_xy(I-1,J ,k)**2 + CS%sh_xy(I,J-1,k)**2) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) enddo; enddo - if (CS%ssd_iter > 0) then - call filter(G, mask_T, mask_q, -1, CS%ssd_iter, T=ssd_11) - call filter(G, mask_T, mask_q, -1, CS%ssd_iter, q=ssd_12) - endif + ! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + elseif (CS%Klower_shear == 1) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) & + + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) & + + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) & + + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo; enddo endif - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, T=sh_xx) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, T=sh_xx) + enddo ! end of k loop - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=sh_xy) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=sh_xy) + call cpu_clock_end(CS%id_clock_cdiss) - call filter(G, mask_T, mask_q, -CS%HPF_iter, CS%HPF_order, q=vort_xy) - call filter(G, mask_T, mask_q, +CS%LPF_iter, CS%LPF_order, q=vort_xy) +end subroutine compute_c_diss - ! Corner to center interpolation (line 901 of MOM_hor_visc.F90) - ! lower index as in loop for sh_xy, but minus 1 - ! upper index is identical - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - sh_xy_center(i,j) = 0.25 * ( (sh_xy(I-1,J-1) + sh_xy(I,J)) & - + (sh_xy(I-1,J) + sh_xy(I,J-1)) ) - vort_xy_center(i,j) = 0.25 * ( (vort_xy(I-1,J-1) + vort_xy(I,J)) & - + (vort_xy(I-1,J) + vort_xy(I,J-1)) ) - enddo ; enddo +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! Which consists of the deviatoric and trace components, respectively: +!! T = (-vort_xy * sh_xy, vort_xy * sh_xx; +!! vort_xy * sh_xx, vort_xy * sh_xy) + +!! 1/2 * (vort_xy^2 + sh_xy^2 + sh_xx^2, 0; +!! 0, vort_xy^2 + sh_xy^2 + sh_xx^2) +!! This stress tensor is multiplied by precomputed kappa=-CS%amplitude * G%area: +!! T -> T * kappa +!! The sign of the stress tensor is such that (neglecting h): +!! (du/dt, dv/dt) = div(T) +!! In symmetric memory model: sh_xy and vort_xy should have halo 1 +!! and zero B.C.; sh_xx should have halo 2 and zero B.C. +!! Result: Txx, Tyy, Txy with halo 1 and zero B.C. +subroutine compute_stress(G, GV, CS) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. + + real :: & + vort_xy_h, & ! Vorticity interpolated to h point [T-1 ~> s-1] + sh_xy_h ! Shearing strain interpolated to h point [T-1 ~> s-1] + + real :: & + sh_xx_q ! Horizontal tension interpolated to q point [T-1 ~> s-1] + + ! Local variables + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) in h point [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2] - ! Center to corner interpolation - ! lower index as in loop for sh_xx - ! upper index as in the same loop, but minus 1 - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 - sh_xx_corner(I,J) = 0.25 * ( (sh_xx(i+1,j+1) + sh_xx(i,j)) & - + (sh_xx(i+1,j) + sh_xx(i,j+1))) - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! WITH land mask (line 622 of MOM_hor_visc.F90) - ! Use of mask eliminates dependence on the - ! values on land - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 - h_u(I,j) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) - enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 - h_v(i,J) = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) - enddo ; enddo + logical :: sum_sq_flag ! Flag to compute trace + logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part - ! Line 1187 of MOM_hor_visc.F90 - do J=js-1,Jeq ; do I=is-1,Ieq - h2uq = 4.0 * (h_u(I,j) * h_u(I,j+1)) - h2vq = 4.0 * (h_v(i,J) * h_v(i+1,J)) - hq(I,J) = (2.0 * (h2uq * h2vq)) & - / (h_neglect3 + (h2uq + h2vq) * ((h_u(I,j) + h_u(I,j+1)) + (h_v(i,J) + h_v(i+1,J)))) - enddo ; enddo + call cpu_clock_begin(CS%id_clock_stress) - ! Form S_11 and S_22 tensors - ! Indices - intersection of loops for - ! sh_xy_center and sh_xx - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (CS%ZB_type == 1) then - sum_sq = 0. - else - sum_sq = 0.5 * & - (vort_xy_center(i,j)**2 + sh_xy_center(i,j)**2 + sh_xx(i,j)**2) - endif + 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%ZB_type == 2) then - vort_sh = 0. - else - if (CS%ZB_cons == 1) then - vort_sh = 0.25 * ( & - (G%areaBu(I-1,J-1) * vort_xy(I-1,J-1) * sh_xy(I-1,J-1) + & - G%areaBu(I ,J ) * vort_xy(I ,J ) * sh_xy(I ,J )) + & - (G%areaBu(I-1,J ) * vort_xy(I-1,J ) * sh_xy(I-1,J ) + & - G%areaBu(I ,J-1) * vort_xy(I ,J-1) * sh_xy(I ,J-1)) & - ) * G%IareaT(i,j) - else if (CS%ZB_cons == 0) then - vort_sh = vort_xy_center(i,j) * sh_xy_center(i,j) - endif + sum_sq = 0. + vort_sh = 0. + + sum_sq_flag = CS%ZB_type /= 1 + vort_sh_scheme_0 = CS%ZB_type /= 2 .and. CS%ZB_cons == 0 + vort_sh_scheme_1 = CS%ZB_type /= 2 .and. CS%ZB_cons == 1 + + do k=1,nz + + ! compute Txx, Tyy tensor + do j=js-1,je+1 ; do i=is-1,ie+1 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + if (sum_sq_flag) then + sum_sq = 0.5 * & + ((vort_xy_h * vort_xy_h & + + sh_xy_h * sh_xy_h) & + + CS%sh_xx(i,j,k) * CS%sh_xx(i,j,k) & + ) endif - k_bc = - CS%amplitude * G%areaT(i,j) - S_11(i,j) = k_bc * (- vort_sh + sum_sq) - S_22(i,j) = k_bc * (+ vort_sh + sum_sq) - enddo ; enddo - ! Form S_12 tensor - ! indices correspond to sh_xx_corner loop - do J=Jsq-1,Jeq ; do I=Isq-1,Ieq - if (CS%ZB_type == 2) then - vort_sh = 0. - else - vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) + if (vort_sh_scheme_0) & + vort_sh = vort_xy_h * sh_xy_h + + if (vort_sh_scheme_1) then + ! It is assumed that B.C. is applied to sh_xy and vort_xy + vort_sh = 0.25 * ( & + ((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k) + & + (G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k)) + & + ((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k) + & + (G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k)) & + ) * G%IareaT(i,j) endif - k_bc = - CS%amplitude * G%areaBu(i,j) - S_12(I,J) = k_bc * vort_sh + + ! B.C. is already applied in kappa_h + CS%Txx(i,j,k) = CS%kappa_h(i,j) * (- vort_sh + sum_sq) + CS%Tyy(i,j,k) = CS%kappa_h(i,j) * (+ vort_sh + sum_sq) + enddo ; enddo - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_11) - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, T=S_22) - call filter(G, mask_T, mask_q, CS%Stress_iter, CS%Stress_order, q=S_12) + ! Here we assume that Txy is initialized to zero + if (CS%ZB_type /= 2) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_q = 0.25 * ( (CS%sh_xx(i+1,j+1,k) + CS%sh_xx(i,j,k)) & + + (CS%sh_xx(i+1,j,k) + CS%sh_xx(i,j+1,k))) + ! B.C. is already applied in kappa_q + CS%Txy(I,J,k) = CS%kappa_q(I,J) * (CS%vort_xy(I,J,k) * sh_xx_q) - if (CS%ssd_iter>-1) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11(i,j) = S_11(i,j) + ssd_11(i,j) - S_22(i,j) = S_22(i,j) - ssd_11(i,j) - enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - S_12(I,J) = S_12(I,J) + ssd_12(I,J) enddo ; enddo endif - if (CS%id_S_11>0) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11_3d(i,j,k) = S_11(i,j) - enddo; enddo - endif + enddo ! end of k loop - if (CS%id_S_22>0) then - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_22_3d(i,j,k) = S_22(i,j) - enddo; enddo - endif + call cpu_clock_end(CS%id_clock_stress) + +end subroutine compute_stress + +!> Compute the divergence of subgrid stress +!! weighted with thickness, i.e. +!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) +!! and update the acceleration due to eddy viscosity as +!! diffu = diffu + dx; diffv = diffv + dy +!! Optionally, before computing the divergence, we attenuate the stress +!! according to the Klower formula. +!! In symmetric memory model: Txx, Tyy, Txy, c_diss should have halo 1 +!! with applied zero B.C. +subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy2q, G, GV, CS) + 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(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + Mxx, & ! Subgrid stress Txx multiplied by thickness and dy^2 [H L4 T-2 ~> m5 s-2] + Myy ! Subgrid stress Tyy multiplied by thickness and dx^2 [H L4 T-2 ~> m5 s-2] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + Mxy ! Subgrid stress Txy multiplied by thickness [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + ZB2020u !< Zonal acceleration due to convergence of + !! along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ZB2020v !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor for ZB model + !! [L T-2 ~> m s-2] + + real :: h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real :: h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: fx ! Zonal acceleration [L T-2 ~> m s-2] + real :: fy ! Meridional acceleration [L T-2 ~> m s-2] + + real :: h_neglect ! Thickness so small it can be lost in + ! roundoff and so neglected [H ~> m or kg m-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + logical :: save_ZB2020u, save_ZB2020v ! Save the acceleration due to ZB2020 model + + call cpu_clock_begin(CS%id_clock_divergence) + + save_ZB2020u = (CS%id_ZB2020u > 0) .or. (CS%id_KE_ZB2020 > 0) + save_ZB2020v = (CS%id_ZB2020v > 0) .or. (CS%id_KE_ZB2020 > 0) + + 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%id_S_12>0) then + h_neglect = GV%H_subroundoff + + do k=1,nz + if (CS%Klower_R_diss > 0) then do J=js-1,Jeq ; do I=is-1,Ieq - S_12_3d(I,J,k) = S_12(I,J) - enddo; enddo + Mxy(I,J) = (CS%Txy(I,J,k) * & + (0.25 * ( (CS%c_diss(i,j ,k) + CS%c_diss(i+1,j+1,k)) & + + (CS%c_diss(i,j+1,k) + CS%c_diss(i+1,j ,k))) & + ) & + ) * CS%hq(I,J,k) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = CS%Txy(I,J,k) * CS%hq(I,J,k) + enddo ; enddo endif - ! Weight with interface height (Line 1478 of MOM_hor_visc.F90) - ! Note that reduction is removed - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - S_11(i,j) = S_11(i,j) * h(i,j,k) - S_22(i,j) = S_22(i,j) * h(i,j,k) - enddo ; enddo - - ! Free slip (Line 1487 of MOM_hor_visc.F90) - do J=js-1,Jeq ; do I=is-1,Ieq - S_12(I,J) = S_12(I,J) * (hq(I,J) * G%mask2dBu(I,J)) - enddo ; enddo + if (CS%Klower_R_diss > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + endif ! Evaluate 1/h x.Div(h S) (Line 1495 of MOM_hor_visc.F90) ! Minus occurs because in original file (du/dt) = - div(S), ! but here is the discretization of div(S) do j=js,je ; do I=Isq,Ieq - fx(I,j,k) = - ((G%IdyCu(I,j)*(dy2h(i,j) *S_11(i,j) - & - dy2h(i+1,j)*S_11(i+1,j)) + & - G%IdxCu(I,j)*(dx2q(I,J-1)*S_12(I,J-1) - & - dx2q(I,J) *S_12(I,J))) * & - G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) + h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect + fx = -((G%IdyCu(I,j)*(Mxx(i,j) - & + Mxx(i+1,j)) + & + G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - & + dx2q(I,J) *Mxy(I,J))) * & + G%IareaCu(I,j)) / h_u + diffu(I,j,k) = diffu(I,j,k) + fx + if (save_ZB2020u) & + ZB2020u(I,j,k) = fx enddo ; enddo ! Evaluate 1/h y.Div(h S) (Line 1517 of MOM_hor_visc.F90) do J=Jsq,Jeq ; do i=is,ie - fy(i,J,k) = - ((G%IdyCv(i,J)*(dy2q(I-1,J)*S_12(I-1,J) - & - dy2q(I,J) *S_12(I,J)) + & ! NOTE this plus - G%IdxCv(i,J)*(dx2h(i,j) *S_22(i,j) - & - dx2h(i,j+1)*S_22(i,j+1))) * & - G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) + h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect + fy = -((G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - & + dy2q(I,J) *Mxy(I,J)) + & ! NOTE this plus + G%IdxCv(i,J)*(Myy(i,j) - & + Myy(i,j+1))) * & + G%IareaCv(i,J)) / h_v + diffv(i,J,k) = diffv(i,J,k) + fy + if (save_ZB2020v) & + ZB2020v(i,J,k) = fy enddo ; enddo enddo ! end of k loop - if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, fx, CS%diag) - if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, fy, CS%diag) - - if (CS%id_maskT>0) call post_data(CS%id_maskT, mask_T_3d, CS%diag) - if (CS%id_maskq>0) call post_data(CS%id_maskq, mask_q_3d, CS%diag) - - if (CS%id_S_11>0) call post_data(CS%id_S_11, S_11_3d, CS%diag) - - if (CS%id_S_22>0) call post_data(CS%id_S_22, S_22_3d, CS%diag) - - if (CS%id_S_12>0) call post_data(CS%id_S_12, S_12_3d, CS%diag) - - call compute_energy_source(u, v, h, fx, fy, G, GV, CS) - -end subroutine Zanna_Bolton_2020 - -!> Filter which is used to smooth velocity gradient tensor -!! or the stress tensor. -!! If n_lowpass and n_highpass are positive, -!! the filter is given by: -!! I - (I-G^n_lowpass)^n_highpass -!! where I is the identity matrix and G is smooth_Tq(). -!! It is filter of order 2*n_highpass, -!! where n_lowpass is the number of iterations -!! which defines the filter scale. -!! If n_lowpass is negative, returns residual -!! for the same filter: -!! (I-G^|n_lowpass|)^n_highpass -!! Input does not require halo. Output has full halo. -subroutine filter(G, mask_T, mask_q, n_lowpass, n_highpass, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - integer, intent(in) :: n_lowpass !< number of low-pass iterations - integer, intent(in) :: n_highpass !< number of high-pass iterations - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + call cpu_clock_end(CS%id_clock_divergence) - real, dimension(SZIB_(G),SZJB_(G)) :: q1, q2 ! intermediate q-fields [arbitrary] - real, dimension(SZI_(G),SZJ_(G)) :: T1, T2 ! intermediate T-fields [arbitrary] - real :: max_before, min_before, max_after, min_after ! minimum and maximum values of fields - ! before and after filtering [arbitrary] + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, ZB2020u, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, ZB2020v, CS%diag) + call cpu_clock_end(CS%id_clock_post) - integer :: i_highpass, i_lowpass - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call compute_energy_source(u, v, h, ZB2020u, ZB2020v, G, GV, CS) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB +end subroutine compute_stress_divergence - if (n_lowpass==0) then - return - endif +!> Filtering of the velocity gradients sh_xx, sh_xy, vort_xy. +!! Here instead of smoothing we do sharpening, i.e. +!! return (initial - smoothed) fields. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input array sh_xx should have halo 2 with +!! applied zero B.C. The arrays sh_xy and vort_xy should have +!! halo 1 with applied B.C. The output have the same halo and B.C. +subroutine filter_velocity_gradients(G, GV, CS) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! Total operator is I - (I-G^n_lowpass)^n_highpass - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q(I,J) * mask_q(I,J) - enddo ; enddo + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + sh_xx ! Copy of CS%sh_xx [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + sh_xy, vort_xy ! Copy of CS%sh_xy and CS%vort_xy [T-1 ~> s-1] - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, q=q) - endif + integer :: xx_halo, xy_halo, vort_halo ! currently available halo for gradient components + integer :: xx_iter, xy_iter, vort_iter ! remaining number of iterations + integer :: niter ! required number of iterations - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q(I,J) - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! q1 -> ((I-G^n_lowpass)^n_highpass)*q1 - do i_highpass=1,n_highpass - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q2(I,J) = q1(I,J) - enddo ; enddo - ! q2 -> (G^n_lowpass)*q2 - do i_lowpass=1,ABS(n_lowpass) - call smooth_Tq(G, mask_T, mask_q, q=q2) - enddo - ! q1 -> (I-G^n_lowpass)*q1 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q1(I,J) - q2(I,J) - enddo ; enddo - enddo + niter = CS%HPF_iter - if (n_lowpass>0) then - ! q -> q - ((I-G^n_lowpass)^n_highpass)*q - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q(I,J) - q1(I,J) - enddo ; enddo - else - ! q -> ((I-G^n_lowpass)^n_highpass)*q - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q1(I,J) - enddo ; enddo - endif + if (niter == 0) return - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, q=q) - if (max_after > max_before .OR. min_after < min_before) then - call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CORNER points "//& - "does not preserve [min,max] values. There may be issues with "//& - "boundary conditions") - endif - endif - endif + 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 (present(T)) then - call pass_var(T, G%Domain) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T(i,j) * mask_T(i,j) - enddo ; enddo + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xx, G%Domain, & + clock=CS%id_clock_mpi) - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, T=T) - endif + ! This is just copy of the array + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + ! Halo of size 2 is valid + do j=js-2,je+2; do i=is-2,ie+2 + sh_xx(i,j,k) = CS%sh_xx(i,j,k) + enddo; enddo + ! Only halo of size 1 is valid + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + sh_xy(I,J,k) = CS%sh_xy(I,J,k) + vort_xy(I,J,k) = CS%vort_xy(I,J,k) + enddo; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T(i,j) - enddo ; enddo + xx_halo = 2; xy_halo = 1; vort_halo = 1; + xx_iter = niter; xy_iter = niter; vort_iter = niter; - do i_highpass=1,n_highpass - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T2(i,j) = T1(i,j) - enddo ; enddo - do i_lowpass=1,ABS(n_lowpass) - call smooth_Tq(G, mask_T, mask_q, T=T2) - enddo - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T1(i,j) - T2(i,j) - enddo ; enddo - enddo + do while & + (xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done + xx_halo < 2 .or. xy_halo < 1) ! there is no halo for VG tensor - if (n_lowpass>0) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T(i,j) - T1(i,j) - enddo ; enddo - else - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T1(i,j) - enddo ; enddo + ! ---------- filtering sh_xx --------- + if (xx_halo < 2) then + call complete_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + xx_halo = CS%HPF_halo endif - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, T=T) - if (max_after > max_before .OR. min_after < min_before) then - call MOM_error(WARNING, "MOM_Zanna_Bolton.F90, filter applied in CENTER points "//& - " does not preserve [min,max] values. There may be issues with "//& - " boundary conditions") - endif - endif - endif -end subroutine filter - -!> One iteration of 3x3 filter -!! [1 2 1; -!! 2 4 2; -!! 1 2 1]/16 -!! removing chess-harmonic. -!! It is used as a buiding block in filter(). -!! Zero Dirichlet boundary conditions are applied -!! with mask_T and mask_q. -subroutine smooth_Tq(G, mask_T, mask_q, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(in) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] + call filter_hq(G, GV, CS, xx_halo, xx_iter, h=CS%sh_xx) - real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate T-field [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate q-field [arbitrary] + if (xx_halo < 2) & + call start_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) - real :: wside ! weights for side points - ! (i+1,j), (i-1,j), (i,j+1), (i,j-1) - ! [nondim] - real :: wcorner ! weights for corner points - ! (i+1,j+1), (i+1,j-1), (i-1,j-1), (i-1,j+1) - ! [nondim] - real :: wcenter ! weight for the center point (i,j) [nondim] + ! ------ filtering sh_xy, vort_xy ---- + if (xy_halo < 1) then + call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + xy_halo = CS%HPF_halo; vort_halo = CS%HPF_halo + endif - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy) + call filter_hq(G, GV, CS, vort_halo, vort_iter, q=CS%vort_xy) - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + if (xy_halo < 1) & + call start_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) - wside = 1. / 8. - wcorner = 1. / 16. - wcenter = 1. - (wside*4. + wcorner*4.) + enddo - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J = Jsq-1, Jeq+1; do I = Isq-1, Ieq+1 - qim(I,J) = q(I,J) * mask_q(I,J) + ! We implement sharpening by computing residual + ! B.C. are already applied to all fields + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + do j=js-2,je+2; do i=is-2,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k) enddo; enddo - do J = Jsq, Jeq - do I = Isq, Ieq - q(I,J) = wcenter * qim(i,j) & - + wcorner * ( & - (qim(I-1,J-1)+qim(I+1,J+1)) & - + (qim(I-1,J+1)+qim(I+1,J-1)) & - ) & - + wside * ( & - (qim(I-1,J)+qim(I+1,J)) & - + (qim(I,J-1)+qim(I,J+1)) & - ) - q(I,J) = q(I,J) * mask_q(I,J) - enddo - enddo - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - endif - - if (present(T)) then - call pass_var(T, G%Domain) - do j = js-1, je+1; do i = is-1, ie+1 - Tim(i,j) = T(i,j) * mask_T(i,j) + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k) + CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k) enddo; enddo - do j = js, je - do i = is, ie - T(i,j) = wcenter * Tim(i,j) & - + wcorner * ( & - (Tim(i-1,j-1)+Tim(i+1,j+1)) & - + (Tim(i-1,j+1)+Tim(i+1,j-1)) & - ) & - + wside * ( & - (Tim(i-1,j)+Tim(i+1,j)) & - + (Tim(i,j-1)+Tim(i,j+1)) & - ) - T(i,j) = T(i,j) * mask_T(i,j) - enddo - enddo - call pass_var(T, G%Domain) - endif + enddo + call cpu_clock_end(CS%id_clock_filter) -end subroutine smooth_Tq + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xy, G%Domain, & + clock=CS%id_clock_mpi) -!> Returns min and max values of array across all PEs. -!! It is used in filter() to check its monotonicity. -subroutine min_max(G, min_val, max_val, T, q) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: T !< any field at T (CENTER) points [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)), & - optional, intent(inout) :: q !< any field at q (CORNER) points [arbitrary] - real, intent(out) :: min_val, max_val !< min and max values of array accross PEs [arbitrary] +end subroutine filter_velocity_gradients - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq +!> Filtering of the stress tensor Txx, Tyy, Txy. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input arrays (Txx, Tyy, Txy) must have halo 1 +!! with zero B.C. applied. The output have the same halo and B.C. +subroutine filter_stress(G, GV, CS) + 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(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + integer :: Txx_halo, Tyy_halo, Txy_halo ! currently available halo for stress components + integer :: Txx_iter, Tyy_iter, Txy_iter ! remaining number of iterations + integer :: niter ! required number of iterations - if (present(q)) then - min_val = minval(q(Isq:Ieq, Jsq:Jeq)) - max_val = maxval(q(Isq:Ieq, Jsq:Jeq)) - endif + niter = CS%Stress_iter - if (present(T)) then - min_val = minval(T(is:ie, js:je)) - max_val = maxval(T(is:ie, js:je)) - endif + if (niter == 0) return - call min_across_PEs(min_val) - call max_across_PEs(max_val) - -end subroutine - -!> Computes mask of wet points in T (CENTER) and q (CORNER) points. -!! Method: compare layer thicknesses with Angstrom_H. -!! Mask is computed separately for every vertical layer and -!! for every time step. -subroutine compute_masks(G, GV, h, mask_T, mask_q, k) - type(ocean_grid_type), intent(in) :: G !< Ocean grid - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: mask_T !< mask of wet points in T (CENTER) points [nondim] - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: mask_q !< mask of wet points in q (CORNER) points [nondim] - integer, intent(in) :: k !< index of vertical layer - - real :: hmin ! Minimum layer thickness - ! beyond which we have boundary [H ~> m or kg m-2] - integer :: i, j + Txx_halo = 1; Tyy_halo = 1; Txy_halo = 1; ! these are required halo for Txx, Tyy, Txy + Txx_iter = niter; Tyy_iter = niter; Txy_iter = niter; + + do while & + (Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done + Txx_halo < 1 .or. Txy_halo < 1) ! there is no halo for Txx or Txy + + ! ---------- filtering Txy ----------- + if (Txy_halo < 1) then + call complete_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + Txy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txy_halo, Txy_iter, q=CS%Txy) + + if (Txy_halo < 1) & + call start_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + + ! ------- filtering Txx, Tyy --------- + if (Txx_halo < 1) then + call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + Txx_halo = CS%Stress_halo; Tyy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx) + call filter_hq(G, GV, CS, Tyy_halo, Tyy_iter, h=CS%Tyy) + + if (Txx_halo < 1) & + call start_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) - hmin = GV%Angstrom_H * 2. - - mask_q(:,:) = 0. - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB - if (h(i+1,j+1,k) < hmin .or. & - h(i ,j ,k) < hmin .or. & - h(i+1,j ,k) < hmin .or. & - h(i ,j+1,k) < hmin & - ) then - mask_q(I,J) = 0. - else - mask_q(I,J) = 1. - endif - mask_q(I,J) = mask_q(I,J) * G%mask2dBu(I,J) - enddo enddo - call pass_var(mask_q, G%Domain, position=CORNER, complete=.true.) - mask_T(:,:) = 0. - do j = G%jsc, G%jec - do i = G%isc, G%iec - if (h(i,j,k) < hmin) then - mask_T(i,j) = 0. +end subroutine filter_stress + +!> Wrapper for filter_3D function. The border indices for q and h +!! arrays are substituted. +subroutine filter_hq(G, GV, CS, current_halo, remaining_iterations, q, h) + 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(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, & + intent(inout) :: h !< Input/output array in h points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), optional, & + intent(inout) :: q !< Input/output array in q points [arbitrary] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + + logical :: direction ! The direction of the first 1D filter + + direction = (MOD(G%first_direction,2) == 0) + + call cpu_clock_begin(CS%id_clock_filter) + + if (present(h)) then + call filter_3D(h, CS%maskw_h, & + G%isd, G%ied, G%jsd, G%jed, & + G%isc, G%iec, G%jsc, G%jec, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + if (present(q)) then + call filter_3D(q, CS%maskw_q, & + G%IsdB, G%IedB, G%JsdB, G%JedB, & + G%IscB, G%IecB, G%JscB, G%JecB, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + call cpu_clock_end(CS%id_clock_filter) +end subroutine filter_hq + +!> Spatial lateral filter applied to 3D array. The lateral filter is given +!! by the convolutional kernel: +!! [1 2 1] +!! C = |2 4 2| * 1/16 +!! [1 2 1] +!! The fast algorithm decomposes the 2D filter into two 1D filters as follows: +!! [1] +!! C = |2| * [1 2 1] * 1/16 +!! [1] +!! The input array must have zero B.C. applied. B.C. is applied for output array. +!! Note that maskw contains both land mask and 1/16 factor. +!! Filter implements marching halo. The available halo is specified and as many +!! filter iterations as possible and as needed are performed. +subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, & + current_halo, remaining_iterations, & + direction) + integer, intent(in) :: isd !< Indices of array size + integer, intent(in) :: ied !< Indices of array size + integer, intent(in) :: jsd !< Indices of array size + integer, intent(in) :: jed !< Indices of array size + integer, intent(in) :: is !< Indices of owned points + integer, intent(in) :: ie !< Indices of owned points + integer, intent(in) :: js !< Indices of owned points + integer, intent(in) :: je !< Indices of owned points + integer, intent(in) :: nz !< Vertical array size + real, dimension(isd:ied,jsd:jed,nz), & + intent(inout) :: x !< Input/output array [arbitrary] + real, dimension(isd:ied,jsd:jed), & + intent(in) :: maskw !< Mask array of land points divided by 16 [nondim] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + logical, intent(in) :: direction !< The direction of the first 1D filter + + real, parameter :: weight = 2. ! Filter weight [nondim] + integer :: i, j, k, iter, niter, halo + + real :: tmp(isd:ied, jsd:jed) ! Array with temporary results [arbitrary] + + ! Do as many iterations as needed and possible + niter = min(current_halo, remaining_iterations) + if (niter == 0) return ! nothing to do + + ! Update remaining iterations + remaining_iterations = remaining_iterations - niter + ! Update halo information + current_halo = current_halo - niter + + do k=1,Nz + halo = niter-1 + & + current_halo ! Save as many halo points as possible + do iter=1,niter + + if (direction) then + do j = js-halo, je+halo; do i = is-halo-1, ie+halo+1 + tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j) + enddo; enddo else - mask_T(i,j) = 1. + do j = js-halo-1, je+halo+1; do i = is-halo, ie+halo + tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j) + enddo; enddo endif - mask_T(i,j) = mask_T(i,j) * G%mask2dT(i,j) + + halo = halo - 1 enddo enddo - call pass_var(mask_T, G%Domain) -end subroutine compute_masks +end subroutine filter_3D !> Computes the 3D energy source term for the ZB2020 scheme !! similarly to MOM_diagnostics.F90, specifically 1125 line. @@ -906,7 +1032,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: fx !< Zonal acceleration due to convergence of @@ -922,11 +1048,6 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) real :: KE_v(SZI_(G),SZJB_(G)) ! The area integral of a KE term in a layer at v-points ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - !real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! temporary array for integration - !real :: global_integral ! Global integral of the energy effect of ZB2020 - ! [H L4 T-3 ~> m5 s-3 or kg m2 s-3] - - real :: uh ! Transport through zonal faces = u*h*dy, ! [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: vh ! Transport through meridional faces = v*h*dx, @@ -937,14 +1058,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k - 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%id_KE_ZB2020 > 0) then + call cpu_clock_begin(CS%id_clock_source) call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + 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 + KE_term(:,:,:) = 0. - !tmp(:,:,:) = 0. ! Calculate the KE source from Zanna-Bolton2020 [H L2 T-3 ~> m3 s-3]. do k=1,nz KE_u(:,:) = 0. @@ -963,14 +1084,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) do j=js,je ; do i=is,ie KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) - ! copy-paste from MOM_spatial_means.F90, line 42 - !tmp(i,j,k) = KE_term(i,j,k) * G%areaT(i,j) * G%mask2dT(i,j) enddo ; enddo enddo - !global_integral = reproducing_sum(tmp) + call cpu_clock_end(CS%id_clock_source) + call cpu_clock_begin(CS%id_clock_post) call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + call cpu_clock_end(CS%id_clock_post) endif end subroutine compute_energy_source diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2d1c38abf9..02b4ec66a6 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -23,7 +23,8 @@ module MOM_hor_visc use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : accel_diag_ptrs -use MOM_Zanna_Bolton, only : Zanna_Bolton_2020, ZB_2020_init, ZB2020_CS +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end, & + ZB2020_CS, ZB2020_copy_gradient_and_thickness implicit none ; private @@ -69,6 +70,11 @@ module MOM_hor_visc logical :: use_beta_in_Leith !< If true, includes the beta term in the Leith viscosity logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith !! nonlinear eddy viscosity. AH is the background. + logical :: use_Leithy !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity with harmonic backscatter. + !! Ah is the background. Leithy = Leith+E + real :: c_K !< Fraction of energy dissipated by the biharmonic term + !! that gets backscattered in the Leith+E scheme. [nondim] 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 @@ -149,10 +155,12 @@ module MOM_hor_visc n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] - 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] + dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] + 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] + m_const_leithy, & !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] + m_leithy_max !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] @@ -250,7 +258,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure @@ -261,18 +269,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + ubtav, & ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + vbtav, & ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + sh_xx_smooth, & ! horizontal tension from smoothed velocity including metric terms [T-1 ~> s-1] sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. @@ -283,23 +296,28 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] + dudx_smooth, dvdy_smooth, & ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot ! The total thickness of all layers [H ~> m or kg m-2] + htot, & ! The total thickness of all layers [H ~> m or kg m-2] + m_leithy ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + dvdx_smooth, dudy_smooth, & ! components in the shearing strain from smoothed velocity [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xy_smooth, & ! horizontal shearing strain from smoothed velocity including metric terms [T-1 ~> s-1] sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] + vort_xy_smooth, & ! Vertical vorticity including metric terms, smoothed [T-1 ~> s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] @@ -334,18 +352,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grid_Re_Ah, & ! Grid Reynolds number for Biharmonic horizontal viscosity at h points [nondim] GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] - ! Zanna-Bolton fields - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - ZB2020u !< Zonal acceleration due to convergence of - !! along-coordinate stress tensor for ZB model - !! [L T-2 ~> m s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & - ZB2020v !< Meridional acceleration due to convergence - !! of along-coordinate stress tensor for ZB model - !! [L T-2 ~> m s-2] - real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] real :: sh_xx_sq ! Square of tension (sh_xx) [T-2 ~> s-2] real :: sh_xy_sq ! Square of shearing strain (sh_xy) [T-2 ~> s-2] @@ -397,6 +406,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] + vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] 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] @@ -409,6 +419,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + m_leithy(:,:) = 0. ! Initialize + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBC = .true. @@ -561,7 +573,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, & + !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & + !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & + !$OMP sh_xx_smooth, sh_xy_smooth, u_smooth, v_smooth, & + !$OMP vert_vort_mag_smooth, m_leithy, AhLthy & !$OMP ) do k=1,nz @@ -590,6 +606,30 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo + if (CS%use_Leithy) then + ! Smooth the velocity. Right now it happens twice. In the future + ! one might make the number of smoothing cycles a user-specified parameter + u_smooth(:,:) = u(:,:,k) + v_smooth(:,:) = v(:,:,k) + call smooth_x9(CS, G, field_u=u_smooth,field_v=v_smooth) ! one call applies the filter twice + ! Calculate horizontal tension from smoothed velocity + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j) - & + G%IdyCu(I-1,j) * u_smooth(I-1,j)) + dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J) - & + G%IdxCv(i,J-1) * v_smooth(i,J-1)) + sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j) + enddo ; enddo + + ! Components for the shearing strain from smoothed velocity + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * & + (v_smooth(i+1,J)*G%IdyCv(i+1,J) - v_smooth(i,J)*G%IdyCv(i,J)) + dudy_smooth(I,J) = CS%DX_dyBu(I,J) * & + (u_smooth(I,j+1)*G%IdxCu(I,j+1) - u_smooth(I,j)*G%IdxCu(I,j)) + enddo ; enddo + end if ! use Leith+E + if (CS%id_normstress > 0) then do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 NoSt(i,j,k) = sh_xx(i,j) @@ -743,6 +783,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + endif + endif ! use Leith+E + ! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u) if (CS%biharmonic) then do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 @@ -780,12 +834,24 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + if (CS%no_slip) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + else + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + endif + endif + ! Divergence do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 div_xx(i,j) = dudx(i,j) + dvdy(i,j) enddo ; enddo - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then ! Vorticity gradient do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 @@ -798,6 +864,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo + if (CS%use_Leithy) then + ! Gradient of smoothed vorticity + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + vort_xy_dx_smooth(i,J) = DY_dxBu * & + (vort_xy_smooth(I,J) * G%IdyCu(I,j) - vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j)) + enddo ; enddo + + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + vort_xy_dy_smooth(I,j) = DX_dyBu * & + (vort_xy_smooth(I,J) * G%IdxCv(i,J) - vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1)) + enddo ; enddo + endif ! If Leithy + ! Laplacian of vorticity do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) @@ -880,6 +961,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) enddo ; enddo + if (CS%use_Leithy) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + vert_vort_mag_smooth(i,j) = SQRT((0.5*(vort_xy_dx_smooth(i,J) + & + vort_xy_dx_smooth(i,J-1)))**2 + & + (0.5*(vort_xy_dy_smooth(I,j) + & + vort_xy_dy_smooth(I-1,j)))**2 ) + enddo ; enddo + endif ! Leithy + endif ! CS%Leith_Kh if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then @@ -905,6 +995,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Laplacian) then + ! Determine the Laplacian viscosity at h points, using the + ! largest value from several parameterizations. Also get + ! the Laplacian component of str_xx. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -919,9 +1013,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - ! Determine the Laplacian viscosity at h points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Kh(i,j) = CS%Kh_bg_xx(i,j) @@ -995,6 +1086,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = 0. + enddo ; enddo + end if + if (CS%id_Kh_h>0 .or. CS%debug) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Kh_h(i,j,k) = Kh(i,j) @@ -1028,7 +1127,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = 0.0 enddo ; enddo - endif + endif ! Get Kh at h points and get Laplacian component of str_xx if (CS%anisotropic) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1041,12 +1140,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%biharmonic) then ! Determine the biharmonic viscosity at h points, using the - ! largest value from several parameterizations. + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xx. do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Ah(i,j) = CS%Ah_bg_xx(i,j) enddo ; enddo - if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then + if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1072,12 +1172,50 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Get m_leithy + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h) + if (AhLth <= CS%Ah_bg_xx(i,j)) then + m_leithy(i,j) = 0.0 + else + if ((CS%m_const_leithy(i,j)*vert_vort_mag(i,j)) < abs(vort_xy_smooth(i,j))) then + m_leithy(i,j) = CS%c_K * (vert_vort_mag(i,j) / vort_xy_smooth(i,j))**2 + else + m_leithy(i,j) = CS%m_leithy_max(i,j) + endif + endif + enddo ; enddo + ! Smooth m_leithy + call smooth_x9(CS, G, field_h=m_leithy, zero_land=.true.) + ! Get Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * & + sqrt(max(0.,Del2vort_h**2 - m_leithy(i,j)*vert_vort_mag_smooth(i,j)**2)) + Ah(i,j) = max(CS%Ah_bg_xx(i,j), AhLthy) + enddo ; enddo + ! Smooth Ah before applying upper bound + ! square, then smooth, then square root + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = Ah(i,j)**2 + enddo ; enddo + call smooth_x9(CS, G, field_h=Ah_h(:,:,k)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = sqrt(Ah_h(i,j,k)) + Ah(i,j) = Ah_h(i,j,k) + enddo ; enddo + endif + if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j)) enddo ; enddo endif - endif ! Smagorinsky_Ah or Leith_Ah + endif ! Smagorinsky_Ah or Leith_Ah or Leith+E if (use_MEKE_Au) then ! *Add* the MEKE contribution @@ -1111,6 +1249,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Compute Leith+E Kh after bounds have been applied to Ah + ! and after it has been smoothed. Kh = -m_leithy * Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = -m_leithy(i,j) * Ah(i,j) + Kh_h(i,j,k) = Kh(i,j) + enddo ; enddo + endif + if (CS%id_grid_Re_Ah>0) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2) @@ -1126,10 +1273,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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) + ! 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)) enddo ; enddo - endif + endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term @@ -1217,7 +1366,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + ! Pass the velocity gradients and thickness to ZB2020 + if (CS%use_ZB2020) then + call ZB2020_copy_gradient_and_thickness( & + sh_xx, sh_xy, vort_xy, & + hq, & + G, GV, CS%ZB2020, k) + endif + if (CS%Laplacian) then + ! Determine the Laplacian viscosity at q points, using the + ! largest value from several parameterizations. Also get the + ! Laplacian component of str_xy. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1232,9 +1393,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - ! Determine the Laplacian viscosity at q points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity do J=js-1,Jeq ; do I=is-1,Ieq Kh(I,J) = CS%Kh_bg_xy(I,J) @@ -1301,6 +1459,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + Kh(I,J) = Kh_h(i+1,j+1,k) + end if + if (CS%id_Kh_q>0 .or. CS%debug) & Kh_q(I,J,k) = Kh(I,J) @@ -1311,14 +1474,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, sh_xy_q(I,J,k) = sh_xy(I,J) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) - enddo ; enddo + 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_smooth(I,J) + enddo ; enddo + endif else do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = 0. enddo ; enddo - endif + endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy if (CS%anisotropic) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1331,7 +1500,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%biharmonic) then ! Determine the biharmonic viscosity at q points, using the - ! largest value from several parameterizations. + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xy. do J=js-1,Jeq ; do I=is-1,Ieq Ah(I,J) = CS%Ah_bg_xy(I,J) enddo ; enddo @@ -1395,6 +1565,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = Ah_h(i+1,j+1,k) + enddo ; enddo + end if + if (CS%id_Ah_q>0 .or. CS%debug) then do J=js-1,Jeq ; do I=is-1,Ieq Ah_q(I,J,k) = Ah(I,J) @@ -1410,7 +1587,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xy(I,J) = d_str * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) enddo ; enddo - endif + endif ! Get Ah at q points and biharmonic part of str_xy if (CS%use_GME) then ! The wider halo here is to permit one pass of smoothing without a halo update. @@ -1622,18 +1799,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop - if (CS%use_ZB2020) then - call Zanna_Bolton_2020(u, v, h, ZB2020u, ZB2020v, G, GV, CS%ZB2020) - - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - diffu(I,j,k) = diffu(I,j,k) + ZB2020u(I,j,k) - enddo ; enddo ; enddo - - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - diffv(i,J,k) = diffv(i,J,k) + ZB2020v(i,J,k) - enddo ; enddo ; enddo - endif - ! Offer fields for diagnostic averaging. if (CS%id_normstress > 0) call post_data(CS%id_normstress, NoSt, CS%diag) if (CS%id_shearstress > 0) call post_data(CS%id_shearstress, ShSt, CS%diag) @@ -1703,6 +1868,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag) endif + if (CS%use_ZB2020) then + call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, & + CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). @@ -1777,7 +1947,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! init control structure - call ZB_2020_init(Time, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) + call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) CS%initialized = .true. @@ -1924,6 +2094,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false., do_not_log=.not.CS%biharmonic) if (.not.CS%biharmonic) CS%Leith_Ah = .false. + call get_param(param_file, mdl, "USE_LEITHY", CS%use_Leithy, & + "If true, use a biharmonic Leith nonlinear eddy "//& + "viscosity together with a harmonic backscatter.", & + default=.false.) 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) @@ -1982,12 +2156,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "Coriolis acceleration. The default is set by MAXVEL.", & units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, & do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis)) - call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & - fail_if_missing=CS%Leith_Ah, do_not_log=.not.CS%Leith_Ah) - + fail_if_missing=(CS%Leith_Ah .or. CS%use_Leithy), & + do_not_log=.not.(CS%Leith_Ah .or. CS%use_Leithy)) call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& @@ -2019,6 +2192,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "with the Gent and McWilliams parameterization.", default=.false.) call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., do_not_log=.true.) + if (CS%use_Leithy) then + if (.not.(CS%biharmonic .and. CS%Laplacian)) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.") + endif + call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & + "Fraction of biharmonic dissipation that gets backscattered, "//& + "in Leith+E.", units="nondim", default=1.0) + endif + if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") @@ -2137,9 +2320,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const2_xy(:,:) = 0.0 endif endif - if (CS%Leith_Ah) then - ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then + ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + endif + if (CS%use_Leithy) then + ALLOC_(CS%m_const_leithy(isd:ied,jsd:jed)) ; CS%m_const_leithy(:,:) = 0.0 + ALLOC_(CS%m_leithy_max(isd:ied,jsd:jed)) ; CS%m_leithy_max(:,:) = 0.0 endif if (CS%Re_Ah > 0.0) then ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 @@ -2282,6 +2469,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (CS%Leith_Ah) then CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) endif + if (CS%use_Leithy) then + CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 + CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) + CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 + 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 if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & @@ -2304,7 +2496,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (abs(G%CoriolisBu(I,J)) * BoundCorConst) endif endif - if (CS%Leith_Ah) then + if ((CS%Leith_Ah) .or. (CS%use_Leithy))then CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) @@ -2646,6 +2838,113 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) enddo ! s-loop end subroutine smooth_GME +!> Apply a 9-point smoothing filter twice to reduce horizontal two-grid-point noise +!! Note that this subroutine does not conserve mass or angular momentum, so don't use it +!! in situations where you need conservation. Also can't apply it to Ah and Kh in the +!! horizontal_viscosity subroutine because they are not supposed to be halo-updated. +!! But you _can_ apply them to Kh_h and Ah_h. +subroutine smooth_x9(CS, G, field_h, field_u, field_v, field_q, 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)), optional, intent(inout) :: field_h !< field to be smoothed + !! at h points + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(inout) :: field_u !< field to be smoothed + !! at u points + real, dimension(SZI_(G),SZJB_(G)), optional, intent(inout) :: field_v !< field to be smoothed + !! at v points + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: field_q !< field to be smoothed + !! at q points + logical, optional, intent(in) :: zero_land !< An optional argument + !! indicating whether to set values + !! on land to zero (.true.) or + !! whether to ignore land values + !! (.false. or not present) + ! local variables. It would be good to make the _original variables allocatable. + real, dimension(SZI_(G),SZJ_(G)) :: field_h_original + real, dimension(SZIB_(G),SZJ_(G)) :: field_u_original + real, dimension(SZI_(G),SZJB_(G)) :: field_v_original + real, dimension(SZIB_(G),SZJB_(G)) :: field_q_original + real, dimension(3,3) :: weights, local_weights ! averaging weights for smoothing, nondimensional + logical :: zero_land_val ! actual value of zero_land optional argument + integer :: i, j, s + integer :: 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 + + weights = reshape([1., 2., 1., 2., 4., 2., 1., 2., 1.],shape(weights))/16. + + if (present(zero_land)) then + zero_land_val = zero_land + else + zero_land_val = .false. + endif + + if (present(field_h)) then + call pass_var(field_h, G%Domain, halo=2) ! Halo size 2 ensures that you can smooth twice + do s=1,0,-1 + field_h_original(:,:) = field_h(:,:) + ! apply smoothing on field_h + do j=js-s,je+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dT(i-1:i+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_h(i,j) = sum(local_weights*field_h_original(i-1:i+1,j-1:j+1)) + enddo ; enddo + enddo + call pass_var(field_h, G%Domain) + endif + + if (present(field_u)) then + call pass_vector(field_u, field_v, G%Domain, halo=2) + do s=1,0,-1 + field_u_original(:,:) = field_u(:,:) + ! apply smoothing on field_u + do j=js-s,je+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dCu(I,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCu(I-1:I+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_u(I,j) = sum(local_weights*field_u_original(I-1:I+1,j-1:j+1)) + enddo ; enddo + + field_v_original(:,:) = field_v(:,:) + ! apply smoothing on field_v + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dCv(i,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCv(i-1:i+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_v(i,J) = sum(local_weights*field_v_original(i-1:i+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_vector(field_u, field_v, G%Domain) + endif + + if (present(field_q)) then + call pass_var(field_q, G%Domain, halo=2, position=CORNER) + do s=1,0,-1 + field_q_original(:,:) = field_q(:,:) + ! apply smoothing on field_q + do J=Jsq-s,Jeq+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dBu(I-1:I+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_q(I,J) = sum(local_weights*field_q_original(I-1:I+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_var(field_q, G%Domain, position=CORNER) + endif + +end subroutine smooth_x9 + !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure @@ -2678,9 +2977,13 @@ subroutine hor_visc_end(CS) if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif - if (CS%Leith_Ah) then + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif + if (CS%use_Leithy) then + DEALLOC_(CS%m_const_leithy) + DEALLOC_(CS%m_leithy_max) + endif if (CS%Re_Ah > 0.0) then DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) endif @@ -2691,6 +2994,11 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_h) DEALLOC_(CS%n1n1_m_n2n2_q) endif + + if (CS%use_ZB2020) then + call ZB2020_end(CS%ZB2020) + endif + end subroutine hor_visc_end !> \namespace mom_hor_visc !! diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 172d2459d5..a8b0d3f813 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,11 +16,13 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info use MOM_io, only : set_axis_info, get_axis_info use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral +use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs @@ -54,6 +56,9 @@ module MOM_internal_tides !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + real, allocatable, dimension(:,:) :: fraction_tidal_input + !< how the energy from one tidal component is distributed + !! over the various vertical modes, 2d in frequency and mode [nondim] real, allocatable, dimension(:,:) :: refl_angle !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) @@ -161,7 +166,7 @@ module MOM_internal_tides ! Diag handles relevant to all modes, frequencies, and angles integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds - integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -1 + integer :: id_tot_En = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 integer :: id_trans = -1, id_residual = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 @@ -172,7 +177,12 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_mode, & id_itidal_loss_mode, & + id_leak_loss_mode, & + id_quad_loss_mode, & + id_Froude_loss_mode, & + id_residual_loss_mode, & id_allprocesses_loss_mode, & + id_itide_drag, & id_Ub_mode, & id_cp_mode ! Diag handles considering: all modes, frequencies, and angles @@ -180,6 +190,7 @@ module MOM_internal_tides id_En_ang_mode, & id_itidal_loss_ang_mode integer, allocatable, dimension(:) :: & + id_TKE_itidal_input, & id_Ustruct_mode, & id_Wstruct_mode, & id_int_w2_mode, & @@ -200,8 +211,7 @@ module MOM_internal_tides !> Calls subroutines in this file that are needed to refract, propagate, !! and dissipate energy density of the internal tide. -subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, dt, & - G, GV, US, CS) +subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_CSp, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -209,10 +219,6 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [R Z3 T-3 ~> W m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: vel_btTide !< Barotropic velocity read - !! from file [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. !! In some cases the input values are used, but in !! others this is set along with the wave speeds. @@ -220,9 +226,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !! reference density [R ~> kg m-3]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. + type(int_tide_input_CS), intent(in) :: inttide_input_CSp !< Internal tide input control structure type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure ! Local variables + real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & + TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),2) :: & test ! A test unit vector used to determine grid rotation in halos [nondim] real, dimension(SZI_(G),SZJ_(G),CS%nMode) :: & @@ -231,15 +242,22 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_En_mode, & ! energy summed over angles only [R Z3 T-2 ~> J m-2] Ub, & ! near-bottom horizontal velocity of wave (modal) [L T-1 ~> m s-1] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + tot_vel_btTide2, & tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - drag_scale, & ! bottom drag scale [T-1 ~> s-1] itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + leak_loss_mode, & + quad_loss_mode, & + Froude_loss_mode, & + residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over ! all angles) [R Z3 T-3 ~> W m-2] + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] @@ -273,7 +291,10 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T ! initialize local arrays - drag_scale(:,:) = 0. + TKE_itidal_input(:,:,:) = 0. + vel_btTide(:,:,:) = 0. + tot_vel_btTide2(:,:) = 0. + drag_scale(:,:,:,:) = 0. Ub(:,:,:,:) = 0. Umax(:,:,:,:) = 0. @@ -329,24 +350,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !enddo ; enddo ; enddo ! Add the forcing.*************************************************************** + + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) + frac_per_sector = 1.0 / real(CS%nAngle) do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) + frac_per_sector = 1.0 a = CS%energized_angle do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -397,6 +421,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq + ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & @@ -479,29 +504,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then - do j=js,je ; do i=is,ie ; htot(i,j) = 0.0 ; enddo ; enddo - do k=1,GV%ke ; do j=js,je ; do i=is,ie + do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo + + call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) + + do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + enddo ; enddo ; enddo + + do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo if (GV%Boussinesq) then ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here - enddo ; enddo + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) - enddo ; enddo + drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * I_mass)) + enddo ; enddo ; enddo ; enddo endif do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j)) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -685,9 +718,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Output two-dimensional diagnostics if (CS%id_tot_En > 0) call post_data(CS%id_tot_En, tot_En, CS%diag) - if (CS%id_itide_drag > 0) call post_data(CS%id_itide_drag, drag_scale, CS%diag) - if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & - TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_input(fr) > 0) call post_data(CS%id_TKE_itidal_input(fr), & + TKE_itidal_input(:,:,fr), CS%diag) + enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + if (CS%id_itide_drag(fr,m) > 0) call post_data(CS%id_itide_drag(fr,m), drag_scale(:,:,fr,m), CS%diag) + enddo ; enddo ! Output 2-D energy density (summed over angles) for each frequency and mode do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then @@ -780,15 +818,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + leak_loss_mode(:,:) = 0.0 + quad_loss_mode(:,:) = 0.0 + Froude_loss_mode(:,:) = 0.0 + residual_loss_mode(:,:) = 0.0 allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + leak_loss_mode(i,j) = leak_loss_mode(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + quad_loss_mode(i,j) = quad_loss_mode(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + Froude_loss_mode(i,j) = Froude_loss_mode(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + residual_loss_mode(i,j) = residual_loss_mode(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & CS%TKE_residual_loss(i,j,a,fr,m)) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) + call post_data(CS%id_leak_loss_mode(fr,m), leak_loss_mode, CS%diag) + call post_data(CS%id_quad_loss_mode(fr,m), quad_loss_mode, CS%diag) + call post_data(CS%id_Froude_loss_mode(fr,m), Froude_loss_mode, CS%diag) + call post_data(CS%id_residual_loss_mode(fr,m), residual_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) endif ; enddo ; enddo @@ -2501,6 +2551,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the ! nominal ocean depth, or a negative value for no limit [nondim] real :: period_1 ! The period of the gravest modeled mode [T ~> s] + real :: period ! A tidal period read from namelist [T ~> s] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2516,6 +2567,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: h2_file character(len=80) :: rough_var ! Input file variable names + character(len=240), dimension(:), allocatable :: energy_fractions + character(len=240) :: periods + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke @@ -2539,17 +2593,29 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode + allocate(energy_fractions(num_freq)) + allocate(CS%fraction_tidal_input(num_freq,num_mode)) + + call read_param(param_file, "ENERGY_FRACTION_PER_MODE", energy_fractions) + + do fr=1,num_freq ; do m=1,num_mode + CS%fraction_tidal_input(fr,m) = extract_real(energy_fractions(fr), " ,", m, 0.) + enddo ; enddo + ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) ! Allocate and populate frequency array (each a multiple of first for now) allocate(CS%frequency(num_freq)) - call get_param(param_file, mdl, "FIRST_MODE_PERIOD", period_1, & - "The period of the first mode for internal tides", default=44567., & - units="s", scale=US%s_to_T) + + + ! The periods of the tidal constituents for internal tides raytracing + call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - CS%frequency(fr) = (8.0*atan(1.0) * (real(fr)) / period_1) ! ADDED BDM + period = extract_real(periods, " ,", fr, 0.) + if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") + CS%frequency(fr) = 8.0*atan(1.0)/period enddo ! Read all relevant parameters and write them to the model log. @@ -2858,14 +2924,18 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) - ! Register 2-D drag scale used for quadratic bottom drag - CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & - Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) - !Register 2-D energy input into internal tides - CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) + allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) + do fr=1,CS%nFreq + ! Register 2-D energy input into internal tides for each frequency + write(var_name, '("TKE_itidal_input_freq",i1)') fr + write(var_descript, '("a fraction of which goes into rays in frequency ",i1)') fr + + CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & + Time, 'Conversion from barotropic to baroclinic tide, '//& + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & @@ -2889,6 +2959,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_leak_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_quad_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Froude_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_residual_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_allprocesses_loss_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_Ub_mode(CS%nFreq,CS%nMode), source=-1) @@ -2929,6 +3003,30 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Leakage loss + write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m + CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Quad loss + write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m + CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Froude loss + write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m + CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! residual losses + write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m + CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m @@ -2958,6 +3056,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) diag%axesT1, Time, var_descript, 'm s-1', conversion=US%L_T_to_m_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Register 2-D drag scale used for quadratic bottom drag for each frequency and mode + write(var_name, '("ITide_drag_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Interior and bottom drag int tide decay timescale in frequency ",i1, " mode ",i1)') fr, m + + CS%id_itide_drag(fr,m) = register_diag_field('ocean_model', var_name, diag%axesT1, Time, & + 's-1', conversion=US%s_to_T) enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 303e41fc3d..8e95edd563 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -794,6 +794,22 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & ! safety check, Kviscosity and Kdiffusivity must be >= 0 do k=1, GV%ke+1 if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + write(*,'(a,3i3)') 'interface, i, j, k = ',j, j, k + write(*,'(a,2f12.5)') 'lon,lat=', G%geoLonT(i,j), G%geoLatT(i,j) + write(*,'(a,es12.4)') 'depth, z_inter(k) =',z_inter(k) + write(*,'(a,es12.4)') 'Kviscosity(k) =',Kviscosity(k) + write(*,'(a,es12.4)') 'Kdiffusivity(k,1) =',Kdiffusivity(k,1) + write(*,'(a,es12.4)') 'Kdiffusivity(k,2) =',Kdiffusivity(k,2) + write(*,'(a,es12.4)') 'OBLdepth =',US%Z_to_m*CS%OBLdepth(i,j) + write(*,'(a,f8.4)') 'kOBL =',CS%kOBL(i,j) + write(*,'(a,es12.4)') 'u* =',surfFricVel + write(*,'(a,es12.4)') 'bottom, z_inter(GV%ke+1) =',z_inter(GV%ke+1) + write(*,'(a,es12.4)') 'CS%La_SL(i,j) =',CS%La_SL(i,j) + write(*,'(a,es12.4)') 'LangEnhK =',LangEnhK + if (present(lamult)) write(*,'(a,es12.4)') 'lamult(i,j) =',lamult(i,j) + write(*,*) 'Kviscosity(:) =',Kviscosity(:) + write(*,*) 'Kdiffusivity(:,1) =',Kdiffusivity(:,1) + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & "Negative vertical viscosity or diffusivity has been detected. " // & "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5b89c8c726..097628c032 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -391,8 +391,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) - call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide_CSp) + call propagate_int_tide(h, tv, CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, & + G, GV, US, CS%int_tide_input_CSp, CS%int_tide_CSp) + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index bbc4c9bf96..7ca432fea4 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -6,13 +6,14 @@ module MOM_diapyc_energy_req !! \author By Robert Hallberg, May 2015 use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -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_specific_vol_derivs, calculate_density +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -59,20 +60,25 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & - optional, intent(in) :: Kd_int !< Interface diffusivities [Z2 T-1 ~> m2 s-1]. + optional, intent(in) :: Kd_int !< Interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real, dimension(GV%ke) :: & T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - h_col ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + h_col, & ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + dz_col ! dz_col is a column of vertical distances across layers at tracer points [Z ~> m] + real, dimension( G%isd:G%ied,GV%ke) :: & + dz_2d ! A 2-d slice of the vertical distance across layers [Z ~> m] real, dimension(GV%ke+1) :: & - Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1]. + Kd, & ! A column of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. + real :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface + ! over the layer thicknesses [H Z-1 ~> nonodim or kg m-3] real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. - real :: tmp1 ! A temporary array [H Z ~> m2 or kg m-1] + real :: tmp1 ! A temporary array [H2 ~> m2 or kg2 m-6] integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -84,36 +90,56 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) "Module must be initialized before it is used.") !$OMP do - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then - do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo - else - htot = 0.0 ; h_top(1) = 0.0 + do j=js,je + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz T0(k) = tv%T(i,j,k) ; S0(k) = tv%S(i,j,k) h_col(k) = h_3d(i,j,k) - h_top(K+1) = h_top(K) + h_col(k) - enddo - htot = h_top(nz+1) - h_bot(nz+1) = 0.0 - do k=nz,1,-1 - h_bot(K) = h_bot(K+1) + h_col(k) + dz_col(k) = dz_2d(i,k) enddo - ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) - Kd(1) = 0.0 ; Kd(nz+1) = 0.0 - do K=2,nz - tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z - Kd(K) = CS%test_Kh_scaling * & - ustar * CS%VonKar * (tmp1*ustar) / (absf*tmp1 + htot*ustar) - enddo - endif - may_print = is_root_PE() .and. (i==ie) .and. (j==je) - call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & - may_print=may_print, CS=CS) - endif ; enddo ; enddo + if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then + do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo + else + htot = 0.0 ; h_top(1) = 0.0 + do k=1,nz + h_top(K+1) = h_top(K) + h_col(k) + enddo + htot = h_top(nz+1) + + h_bot(nz+1) = 0.0 + do k=nz,1,-1 + h_bot(K) = h_bot(K+1) + h_col(k) + enddo + + ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? + absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + Kd(1) = 0.0 ; Kd(nz+1) = 0.0 + if (GV%Boussinesq) then + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (absf*GV%H_to_Z*tmp1 + htot*ustar) + enddo + else + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + dz_h_int = (dz_2d(j,k-1) + dz_2d(j,k) + GV%dz_subroundoff) / & + (h_3d(i,j,k-1) + h_3d(i,j,k) + GV%H_subroundoff) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (dz_h_int*absf*tmp1 + htot*ustar) + enddo + endif + endif + may_print = is_root_PE() .and. (i==ie) .and. (j==je) + call diapyc_energy_req_calc(h_col, dz_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & + may_print=may_print, CS=CS) + endif ; enddo + enddo end subroutine diapyc_energy_req_test @@ -123,17 +149,19 @@ end subroutine diapyc_energy_req_test !! 4 different ways, all of which should be equivalent, but reports only one. !! The various estimates are taken because they will later be used as templates !! for other bits of code -subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & +subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv, & G, GV, US, may_print, CS) 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 real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, - !! [H ~> m or kg m-2]. + !! [H ~> m or kg m-2] + real, dimension(GV%ke), intent(in) :: dz_in !< Vertical distance across layers before + !! entrainment [Z ~> m] real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [C ~> degC]. real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [S ~> ppt]. real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. @@ -157,11 +185,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. T0, S0, & ! Initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] Tf, Sf, & ! New final values of the temperatures and salinities [C ~> degC] and [S ~> ppt]. - dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [C ~> degC] and [S ~> ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -210,8 +234,18 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! in the denominator of b1 in an upward-oriented tridiagonal solver. c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. - h_tr ! h_tr is h at tracer points with a h_neglect added to + h_tr, & ! h_tr is h at tracer points with a h_neglect added to ! ensure positive definiteness [H ~> m or kg m-2]. + dz_tr ! dz_tr is dz at tracer points with dz_neglect added to + ! ensure positive definiteness [Z ~> m] + ! Note that the following arrays have extra (ficticious) layers above or below the + ! water column for code convenience + real, dimension(0:GV%ke+1) :: & + Te, Se ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(0:GV%ke) :: & + Te_a, Se_a ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + Te_b, Se_b ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -238,10 +272,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface [C H ~> degC m or degC kg m-2]. - real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer below the interface [S H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. @@ -251,10 +281,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: ColHt_cor ! The correction to PE_chg that is made due to a net ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. - real :: dTe_t2 ! Temporary arrays with integrated temperature changes [C H ~> degC m or degC kg m-2] - real :: dSe_t2 ! Temporary arrays with integrated salinity changes [S H ~> ppt m or ppt kg m-2] - real :: dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [C ~> degC]. - real :: dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [S ~> ppt]. + real :: dztot ! A running sum of vertical distances across layers [Z ~> m] logical :: do_print ! The following are a bunch of diagnostic arrays for debugging purposes. @@ -282,7 +309,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug - logical :: old_PE_calc nz = GV%ke h_neglect = GV%H_subroundoff @@ -298,11 +324,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 - htot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 + htot = 0.0 ; dztot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) + dz_tr(k) = dz_in(k) htot = htot + h_tr(k) + dztot = dztot + dz_tr(k) pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) pres_Z(K+1) = pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) @@ -310,15 +338,23 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo do k=1,nz h_tr(k) = max(h_tr(k), 1e-15*htot) + dz_tr(k) = max(dz_tr(k), 1e-15*dztot) enddo ! Introduce a diffusive flux variable, Kddt_h(K) = ea(k) = eb(k-1) Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 do K=2,nz - Kddt_h(K) = min((GV%Z_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))), 1e3*htot) + Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo + ! Zero out the temperature and salinity estimates in the extra (ficticious) layers. + ! The actual values set here are irrelevant (so long as they are not NaNs) because they + ! are always multiplied by a zero value of Kddt_h reflecting the no-flux boundary condition. + Te(0) = 0.0 ; Se(0) = 0.0 ; Te(nz+1) = 0.0 ; Se(nz+1) = 0.0 + Te_a(0) = 0.0 ; Se_a(0) = 0.0 + Te_b(nz+1) = 0.0 ; Se_b(nz+1) = 0.0 + ! Solve the tridiagonal equations for new temperatures. call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state) @@ -337,7 +373,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 if (surface_BL) then ! This version is appropriate for a surface boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -353,71 +388,32 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==2) then - dT_km1_t2 = (T0(k)-T0(k-1)) - dS_km1_t2 = (S0(k)-S0(k-1)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - dT_km1_t2 = (T0(k)-T0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dS_km1_t2 = (S0(k)-S0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - dTe_term = dTe_t2 + hp_a(k-1) * (T0(k-1)-T0(k)) - dSe_term = dSe_t2 + hp_a(k-1) * (S0(k-1)-S0(k)) - else - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) - endif - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg_k(k,1), dPEa_dKd(k)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & - ColHt_cor=ColHt_cor_k(K,1)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,1)) if (debug) then do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) enddo ! Compare with a 4th-order finite difference estimate. dPEa_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -434,17 +430,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) c1_a(K) = Kddt_h(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) - endif - if (old_PE_calc) then - dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) - dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) - endif + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -457,10 +444,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(nz)) Tf(nz) = b1 * (h_tr(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) Sf(nz) = b1 * (h_tr(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) - if (old_PE_calc) then - dTe(nz) = b1 * Kddt_h(nz) * ((T0(nz-1)-T0(nz)) + dTe(nz-1)) - dSe(nz) = b1 * Kddt_h(nz) * ((S0(nz-1)-S0(nz)) + dSe(nz-1)) - endif do k=nz-1,1,-1 Tf(k) = Te(k) + c1_a(K+1)*Tf(k+1) @@ -483,7 +466,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & endif if (bottom_BL) then ! This version is appropriate for a bottom boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -499,71 +481,32 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==nz) then - dT_k_t2 = (T0(k-1)-T0(k)) - dS_k_t2 = (S0(k-1)-S0(k)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K+1) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dSe_t2 = Kddt_h(K+1) * ((S0(k+1) - S0(k)) + dSe(k+1)) - dT_k_t2 = (T0(k-1)-T0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dS_k_t2 = (S0(k-1)-S0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((S0(k+1) - S0(k)) + dSe(k+1)) - endif - dTe_term = dTe_t2 + hp_b(k) * (T0(k)-T0(k-1)) - dSe_term = dSe_t2 + hp_b(k) * (S0(k)-S0(k-1)) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1) - endif - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & - ColHt_cor=ColHt_cor_k(K,2)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,2)) if (debug) then ! Compare with a 4th-order finite difference estimate. do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif enddo dPEb_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -580,17 +523,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(k) + Kddt_h(K)) c1_b(K) = Kddt_h(K) * b1 - if (k==nz) then - Te(nz) = b1* (h_tr(nz)*T0(nz)) - Se(nz) = b1* (h_tr(nz)*S0(nz)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1)) - endif - if (old_PE_calc) then - dTe(k) = b1 * ( Kddt_h(K)*(T0(k-1)-T0(k)) + dTe_t2 ) - dSe(k) = b1 * ( Kddt_h(K)*(S0(k-1)-S0(k)) + dSe_t2 ) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -603,10 +538,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(1)) Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) - if (old_PE_calc) then - dTe(1) = b1 * Kddt_h(2) * ((T0(2)-T0(1)) + dTe(2)) - dSe(1) = b1 * Kddt_h(2) * ((S0(2)-S0(1)) + dSe(2)) - endif do k=2,nz Tf(k) = Te(k) + c1_b(K)*Tf(k-1) @@ -644,12 +575,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) @@ -660,19 +588,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_change ColHt_cor_k(K,3) = ColHt_cor b1 = 1.0 / (hp_a(k-1) + Kddt_h_a(K)) c1_a(K) = Kddt_h_a(K) * b1 - if (k==2) then - Te_a(1) = b1*(h_tr(1)*T0(1)) - Se_a(1) = b1*(h_tr(1)*S0(1)) - else - Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) - Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) - endif + + Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) + Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h_a(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -686,18 +610,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). -! if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) -! else -! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) -! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) -! endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) +! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) +! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) Kddt_h_b(K) = 0.0 ; if (K > K_cent) Kddt_h_b(K) = Kddt_h(K) dKd = Kddt_h_b(K) @@ -707,19 +626,15 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor b1 = 1.0 / (hp_b(k) + Kddt_h_b(K)) c1_b(K) = Kddt_h_b(K) * b1 - if (k==nz) then - Te_b(k) = b1 * (h_tr(k)*T0(k)) - Se_b(k) = b1 * (h_tr(k)*S0(k)) - else - Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) - Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(k+1) * Se_b(k+1)) - endif + + Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) + Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(K+1) * Se_b(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h_b(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -734,18 +649,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) dKd = Kddt_h(K) @@ -754,7 +662,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor @@ -820,16 +728,12 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo ! Calculate the dependencies on layers above. - Kddt_h_a(1) = 0.0 do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) dKd = 0.5 * Kddt_h(K) - Kd_so_far(K) @@ -839,7 +743,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_change ColHt_cor_k(K,4) = ColHt_cor @@ -848,13 +752,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_a(k-1) + Kd_so_far(K)) c1_a(K) = Kd_so_far(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) - endif + + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kd_so_far(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -867,18 +767,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) dKd = Kddt_h(K) - Kd_so_far(K) @@ -887,7 +780,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_chg_k(K,4) + PE_change ColHt_cor_k(K,4) = ColHt_cor_k(K,4) + ColHt_cor @@ -897,13 +790,9 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & b1 = 1.0 / (hp_b(k) + Kd_so_far(K)) c1_b(K) = Kd_so_far(K) * b1 - if (k==nz) then - Te(k) = b1 * (h_tr(k)*T0(k)) - Se(k) = b1 * (h_tr(k)*S0(k)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kd_so_far(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -962,7 +851,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) enddo @@ -973,7 +862,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) enddo @@ -984,11 +873,11 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & end subroutine diapyc_energy_req_calc !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. @@ -1016,22 +905,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! below, including implicit mixing effects with other !! yet lower layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating @@ -1051,8 +940,8 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! height, including all implicit diffusive changes !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could @@ -1060,17 +949,18 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net !! change in the column height [R Z L2 T-2 ~> J m-2]. + ! Local variables real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. - real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> psu m2 or psu kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [R L2 T-2 ~> J m-3]. + ! for the potential energy changes [H3 R Z L2 T-2 ~> J m or J kg3 m-8]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [R L2 T-2 ~> J m-3]. + ! for the column height changes [H3 Z ~> m4 or kg3 m-5]. real :: ColHt_chg ! The change in the column height [Z ~> m]. real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. @@ -1078,7 +968,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1092,18 +982,14 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) - if (present(PE_chg)) then - ! Find the change in column potential energy due to the change in the - ! diffusivity at this interface by dKddt_h. - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - PE_chg = PEc_core * y1_3 - ColHt_chg = ColHt_core * y1_3 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) - elseif (present(ColHt_cor)) then - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres_Z * min(ColHt_core * y1_3, 0.0) - endif + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) if (present(dPEc_dKd)) then ! Find the derivative of the potential energy change with dKddt_h. @@ -1132,164 +1018,6 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & end subroutine find_PE_chg -!> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep -!! using the original form used in the first version of ePBL. -subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & - dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) - real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and - !! divided by the average of the thicknesses around the - !! interface [H ~> m or kg m-2]. - real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. - real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot - !! for the tridiagonal solver, given by h_k plus a term that - !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above [H ~> m or kg m-2]. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change - !! in the layer below the interface [C H ~> degC m or degC kg m-2]. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change - !! in the layer below the interface [S H ~> ppt m or ppt kg m-2]. - real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface [C ~> degC]. - real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface [S ~> ppt]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate - !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. - real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. - - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realized by applying a huge value of Kddt_h at the - !! present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - -! This subroutine determines the total potential energy change due to mixing -! at an interface, including all of the implicit effects of the prescribed -! mixing at interfaces above. Everything here is derived by careful manipulation -! of the robust tridiagonal solvers used for tracers by MOM6. The results are -! positive for mixing in a stably stratified environment. -! The comments describing these arguments are for a downward mixing pass, but -! this routine can also be used for an upward pass with the sense of direction -! reversed. - - real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: b1Kd ! Temporary array [nondim] - real :: ColHt_chg ! The change in column thickness [Z ~> m]. - real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] - real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [C ~> degC] - real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [S ~> ppt] - real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes - ! per unit change in Kddt_h [C H-1 ~> degC m-1 or degC m2 kg-1] - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes - ! per unit change in Kddt_h [S H-1 ~> ppt m-1 or ppt m2 kg-1] - - b1 = 1.0 / (b_den_1 + Kddt_h) - b1Kd = Kddt_h*b1 - - ! Start with the temperature change in layer k-1 due to the diffusivity at - ! interface K without considering the effects of changes in layer k. - - ! Calculate the change in PE due to the diffusion at interface K - ! if Kddt_h(K+1) = 0. - I_Kr_denom = 1.0 / (h_k*b_den_1 + (b_den_1 + h_k)*Kddt_h) - - dT_k = (Kddt_h*I_Kr_denom) * dTe_term - dS_k = (Kddt_h*I_Kr_denom) * dSe_term - - if (present(PE_chg)) then - ! Find the change in energy due to diffusion with strength Kddt_h at this interface. - ! Increment the temperature changes in layer k-1 due the changes in layer k. - dT_km1 = b1Kd * ( dT_k + dT_km1_t2 ) - dS_km1 = b1Kd * ( dS_k + dS_km1_t2 ) - - PE_chg = (dT_to_dPE_k * dT_k + dT_to_dPEa * dT_km1) + & - (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) - ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & - (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - endif - - if (present(dPEc_dKd)) then - ! Find the derivatives of the temperature and salinity changes with Kddt_h. - dKr_dKd = (h_k*b_den_1) * I_Kr_denom**2 - - ddT_k_dKd = dKr_dKd * dTe_term - ddS_k_dKd = dKr_dKd * dSe_term - ddT_km1_dKd = (b1**2 * b_den_1) * ( dT_k + dT_km1_t2 ) + b1Kd * ddT_k_dKd - ddS_km1_dKd = (b1**2 * b_den_1) * ( dS_k + dS_km1_t2 ) + b1Kd * ddS_k_dKd - - ! Calculate the partial derivative of Pe_chg with Kddt_h. - dPEc_dKd = (dT_to_dPE_k * ddT_k_dKd + dT_to_dPEa * ddT_km1_dKd) + & - (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) - dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & - (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd - endif - - if (present(dPE_max)) then - ! This expression is the limit of PE_chg for infinite Kddt_h. - dPE_max = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) + & - ((dT_to_dPE_k + dT_to_dPEa) * dTe_term + & - (dS_to_dPE_k + dS_to_dPEa) * dSe_term) / (b_den_1 + h_k) - dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & - ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & - (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max - endif - - if (present(dPEc_dKd_0)) then - ! This expression is the limit of dPEc_dKd for Kddt_h = 0. - dPEc_dKd_0 = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) / (b_den_1) + & - (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) - dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & - (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd - endif - -end subroutine find_PE_chg_orig - !> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< model time diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 3da21b48fb..7280106125 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -11,11 +11,13 @@ module MOM_int_tide_input use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_string_functions, only : extractWord use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d @@ -27,6 +29,7 @@ module MOM_int_tide_input #include public set_int_tide_input, int_tide_input_init, int_tide_input_end +public get_input_TKE, get_barotropic_tidal_vel ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -44,9 +47,13 @@ module MOM_int_tide_input real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real, allocatable, dimension(:,:) :: TKE_itidal_coef + real, allocatable, dimension(:,:,:) :: TKE_itidal_coef !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. + real, allocatable, dimension(:,:,:) :: & + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. + character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -59,19 +66,19 @@ module MOM_int_tide_input integer :: int_tide_source_i !< I Location of generation site integer :: int_tide_source_j !< J Location of generation site logical :: int_tide_use_glob_ij !< Use global indices for generation site + integer :: nFreq = 0 !< The number of internal tide frequency bands !>@{ Diagnostic IDs - integer :: id_TKE_itidal_itide = -1, id_Nb = -1, id_N2_bot = -1 + integer, allocatable, dimension(:) :: id_TKE_itidal_itide + integer :: id_Nb = -1, id_N2_bot = -1 !>@} end type int_tide_input_CS !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. - tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. Nb, & !< The bottom stratification [T-1 ~> s-1]. Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type @@ -110,6 +117,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global + integer :: fr 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 @@ -133,52 +141,55 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (GV%Boussinesq .or. GV%semi_Boussinesq) then !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo ; enddo else !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - itide%TKE_itidal_input(i,j) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), & + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & CS%TKE_itide_max) - enddo ; enddo + enddo ; enddo ; enddo endif if (CS%int_tide_source_test) then - itide%TKE_itidal_input(:,:) = 0.0 + CS%TKE_itidal_input(:,:,:) = 0.0 if (time_end <= CS%time_max_source) then if (CS%int_tide_use_glob_ij) then - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo endif endif endif if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & scale=US%RZ3_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) - if (CS%id_TKE_itidal_itide > 0) call post_data(CS%id_TKE_itidal_itide, itide%TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_itide(fr) > 0) call post_data(CS%id_TKE_itidal_itide(fr), & + CS%TKE_itidal_input(isd:ied,jsd:jed,fr), CS%diag) + enddo if (CS%id_Nb > 0) call post_data(CS%id_Nb, itide%Nb, CS%diag) if (CS%id_N2_bot > 0 ) call post_data(CS%id_N2_bot, N2_bot, CS%diag) @@ -319,6 +330,38 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo end subroutine find_N2_bottom +!> Returns TKE_itidal_input +subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + TKE_itidal_input(i,j,fr) = CS%TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_input_TKE + +!> Returns barotropic tidal velocities +subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + vel_btTide(i,j,fr) = CS%tideamp(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_barotropic_tidal_vel + !> Initializes the data related to the internal tide input module subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(time_type), intent(in) :: Time !< The current model time @@ -337,6 +380,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths character(len=80) :: tideamp_var, rough_var ! Input file variable names + character(len=80) :: var_name + character(len=200) :: var_descript + character(len=200) :: tidefile_varnames real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness @@ -349,6 +395,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: num_freq, fr if (associated(CS)) then call MOM_error(WARNING, "int_tide_input_init called with an associated "// & @@ -390,12 +437,15 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + CS%nFreq= num_freq + allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) - allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) - allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) - allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_input(isd:ied,jsd:jed,num_freq), source=0.0) + allocate(CS%tideamp(isd:ied,jsd:jed,num_freq), source=utide) + allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed, num_freq), source=0.0) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& @@ -419,10 +469,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & - "The name of the tidal amplitude variable in the input file.", & - default="tideamp") - call MOM_read_data(filename, tideamp_var, itide%tideamp, G%domain, scale=US%m_s_to_L_T) + + call read_param(param_file, "INTTIDE_AMP_VARNAMES", tidefile_varnames) + do fr=1,num_freq + tideamp_var = extractWord(tidefile_varnames,fr) + call MOM_read_data(filename, tideamp_var, CS%tideamp(:,:,fr), G%domain, scale=US%m_s_to_L_T) + enddo + endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -475,25 +528,31 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif endif - do j=js,je ; do i=is,ie + do fr=1,num_freq ; do j=js,je ; do i=is,ie mask_itidal = 1.0 if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0 - itide%tideamp(i,j) = itide%tideamp(i,j) * mask_itidal * G%mask2dT(i,j) + CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j) ! Restrict rms topo to a fraction (often 10 percent) of the column depth. if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & - kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo ; enddo + CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & + kappa_itides * itide%h2(i,j) * CS%tideamp(i,j,fr)**2 + enddo ; enddo ; enddo - CS%id_TKE_itidal_itide = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + allocate( CS%id_TKE_itidal_itide(num_freq), source=-1) + + do fr=1,num_freq + write(var_name, '("TKE_itidal_itide_freq",i1)') fr + write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr + + CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index a6c463a7b9..57cddeca5c 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -36,7 +36,8 @@ module MOM_set_visc #include public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end -public set_visc_register_restarts, remap_vertvisc_aux_vars +public set_visc_register_restarts, set_u_at_v, set_v_at_u +public remap_vertvisc_aux_vars ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 212512dabf..8d41fcb63a 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -3,6 +3,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domains, only : pass_var, To_All, Omit_corners +use MOM_domains, only : pass_vector, Scalar_Pair use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v @@ -27,6 +28,7 @@ module MOM_vert_friction use MOM_variables, only : ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS +use MOM_set_visc, only : set_v_at_u, set_u_at_v use MOM_lateral_mixing_coeffs, only : VarMix_CS implicit none ; private @@ -36,6 +38,7 @@ module MOM_vert_friction public vertvisc, vertvisc_remnant, vertvisc_coef public vertvisc_limit_vel, vertvisc_init, vertvisc_end public updateCFLtruncationValue +public vertFPmix ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional ! consistency testing. These are noted in comments with units like Z, H, L, and T, along with @@ -167,6 +170,9 @@ module MOM_vert_friction integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 + integer :: id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 + integer :: id_tauFP_u = -1, id_tauFP_v = -1 !W, id_FPtau2x_u = -1, id_FPtau2x_v = -1 + integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 integer :: id_Kv_gl90_u = -1, id_Kv_gl90_v = -1 @@ -185,6 +191,381 @@ module MOM_vert_friction contains +!> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. +subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: hbl_h !< boundary layer depth [H ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + + ! local variables + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth at v-pts [H ~> m] + integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u !< index of the BLD at u-pts [nondim] + integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v !< index of the BLD at v-pts [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u !< ustar squared at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v !< ustar squared at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< zonal wind stress at u-pts [R L Z T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< meridional wind stress at v-pts [R L Z T-2 ~> Pa] + !real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] + !real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !< kinematic zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v !< kinematic mer. mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u !< downgradient zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u !< downgradient meri mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v !< downgradient zonal mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v !< downgradient meri mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u !< angle between mtm flux and vert shear at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v !< angle between mtm flux and vert shear at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u !< angle between mtm flux and wind at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v !< angle between mtm flux and wind at v-pts [rad] + + real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp !< constants and dummy variables + real :: du, dv, depth, sigma, Wind_x, Wind_y !< intermediate variables + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables + real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles + integer :: kblmin, kbld, kp1, k, nz !< vertical indices + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices + + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + pi = 4. * atan2(1.,1.) + Cemp_CG = 3.6 + kblmin = 1 + taux_u(:,:) = 0. + tauy_v(:,:) = 0. + + do j = js,je + do I = Isq,Ieq + taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ !W rho0=1035. + enddo + enddo + + do J = Jsq,Jeq + do i = is,ie + tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ + enddo + enddo + + call pass_var( hbl_h ,G%Domain, halo=1 ) + call pass_vector(taux_u , tauy_v, G%Domain, To_All ) + ustar2_u(:,:) = 0. + ustar2_v(:,:) = 0. + hbl_u(:,:) = 0. + hbl_v(:,:) = 0. + kbl_u(:,:) = 0 + kbl_v(:,:) = 0 + !omega_w2x_u(:,:) = 0.0 + !omega_w2x_v(:,:) = 0.0 + tauxDG_u(:,:,:) = 0.0 + tauyDG_v(:,:,:) = 0.0 + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j) * hbl_h(i+1,j)) /tmp + tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) + tauy = ( G%mask2dCv(i ,j )*tauy_v(i ,j ) + G%mask2dCv(i ,j-1)*tauy_v(i ,j-1) & + + G%mask2dCv(i+1,j )*tauy_v(i+1,j ) + G%mask2dCv(i+1,j-1)*tauy_v(i+1,j-1) ) / tmp + ustar2_u(I,j) = sqrt( taux_u(I,j)*taux_u(I,j) + tauy*tauy ) + !omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) + tauxDG_u(I,j,1) = taux_u(I,j) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_u(I,j,k) + if( (depth >= hbl_u(I,j)) .and. (kbl_u(I,j) == 0 ) .and. (k > (kblmin-1)) ) then + kbl_u(I,j) = k + hbl_u(I,j) = depth + endif + enddo + endif + enddo + enddo + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + tmp = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) + hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp + tmp = max(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1))) + taux = ( G%mask2dCu(i ,j) * taux_u(i ,j) + G%mask2dCu(i ,j+1) * taux_u(i ,j+1) & + + G%mask2dCu(i-1,j) * taux_u(i-1,j) + G%mask2dCu(i-1,j+1) * taux_u(i-1,j+1)) / tmp + ustar2_v(i,J) = sqrt(tauy_v(i,J)*tauy_v(i,J) + taux*taux) + !omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) + tauyDG_v(i,J,1) = tauy_v(i,J) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_v(i,J,k) + if( (depth >= hbl_v(i,J)) .and. (kbl_v(i,J) == 0) .and. (k > (kblmin-1))) then + kbl_v(i,J) = k + hbl_v(i,J) = depth + endif + enddo + endif + enddo + enddo + + if (CS%debug) then + call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) + call uvchksum("ustar2", ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" hbl", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) + endif + + ! Compute downgradient stresses + do k = 1, nz + kp1 = min( k+1 , nz) + do j = js ,je + do I = Isq , Ieq + tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp1) * (ui(I,j,k) - ui(I,j,kp1)) + enddo + enddo + do J = Jsq , Jeq + do i = is , ie + tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp1) * (vi(i,J,k) - vi(i,J,kp1)) + enddo + enddo + enddo + + call pass_vector(tauxDG_u, tauyDG_v , G%Domain, To_All) + call pass_vector(ui,vi, G%Domain, To_All) + tauxDG_v(:,:,:) = 0. + tauyDG_u(:,:,:) = 0. + + ! Thickness weighted interpolations + do k = 1, nz + ! v to u points + do j = js , je + do I = Isq, Ieq + tauyDG_u(I,j,k) = set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) + enddo + enddo + ! u to v points + do J = Jsq, Jeq + do i = is, ie + tauxDG_v(i,J,k) = set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) + enddo + enddo + enddo + if (CS%debug) then + call uvchksum(" tauyDG_u tauxDG_v",tauyDG_u,tauxDG_v, G%HI, haloshift=0, scalar_pair=.true.) + endif + + ! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2w_[u,v] and stress mag tau_[u,v] + omega_tau2w_u(:,:,:) = 0.0 + omega_tau2w_v(:,:,:) = 0.0 + omega_tau2s_u(:,:,:) = 0.0 + omega_tau2s_v(:,:,:) = 0.0 + tau_u(:,:,:) = 0.0 + tau_v(:,:,:) = 0.0 + + ! stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + ! SURFACE + tauyDG_u(I,j,1) = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) + tau_u(I,j,1) = ustar2_u(I,j) + Omega_tau2w_u(I,j,1) = 0.0 + Omega_tau2s_u(I,j,1) = 0.0 + + do k=1,nz + kp1 = MIN(k+1 , nz) + tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) + Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) + omega_tmp = Omega_tau2x !- omega_w2x_u(I,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tmp + Omega_tau2s_u(I,j,k+1) = 0.0 + enddo + endif + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + if( (G%mask2dCv(i,J) > 0.5) ) then + ! SURFACE + tauxDG_v(i,J,1) = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) + tau_v(i,J,1) = ustar2_v(i,J) + Omega_tau2w_v(i,J,1) = 0.0 + Omega_tau2s_v(i,J,1) = 0.0 + + do k=1,nz-1 + kp1 = MIN(k+1 , nz) + tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) + omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) + omega_tmp = omega_tau2x !- omega_w2x_v(i,J) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tmp + Omega_tau2s_v(i,J,k+1) = 0.0 + enddo + endif + enddo + enddo + + ! Parameterized stress orientation from the wind at interfaces (tau2x) + ! and centers (tau2x) OVERWRITE to kbl-interface above hbl + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + kbld = min( (kbl_u(I,j)) , (nz-2) ) + if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 + + tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff + ! surface boundary conditions + depth = 0. + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_u(I,j,k) + sigma = min( 1.0 , depth / hbl_u(i,j) ) + + ! linear stress mag + tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) + cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + + ! rotate to wind coordinates + Wind_x = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) + Wind_y = ustar2_u(I,j) !* sin(omega_w2x_u(I,j)) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG, tauNL_DG) + omega_s2w = 0.0-omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = max(tau_MAG, tauNL_CG) + tauNL_DG = sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) - tau_u(I,j,k+1) + + ! back to x,y coordinates + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) + tauNLdn = tauNL_X + + ! nonlocal increment and update to uold + du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) + ui(I,j,k) = uold(I,j,k) + du + uold(I,j,k) = du + tauNLup = tauNLdn + + ! diagnostics + Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG)) + tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2) + omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X)) + omega_tau2w = omega_tau2x !- omega_w2x_u(I,j) + if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tau2w + enddo + do k= kbld+1, nz + ui(I,j,k) = uold(I,j,k) + uold(I,j,k) = 0.0 + enddo + endif + enddo + enddo + + ! v-point dv increment + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + kbld = min((kbl_v(i,J)), (nz-2)) + if (tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1)) kbld = kbld + 1 + tauh = tau_v(i,J,kbld+1) + + !surface boundary conditions + depth = 0. + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_v(i,J,k) + sigma = min(1.0, depth/ hbl_v(I,J)) + + ! linear stress + tau_MAG = (ustar2_v(i,J) * (1.-sigma)) + (tauh * sigma) + cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + + ! rotate into wind coordinate + Wind_x = ustar2_v(i,J) !* cos(omega_w2x_v(i,J)) + Wind_y = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG , tauNL_DG) + omega_s2w = 0.0 - omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = max( tau_MAG , tauNL_CG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) + + ! back to x,y coordinate + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) + tauNLdn = tauNL_Y + dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) + vi(i,J,k) = vold(i,J,k) + dv + vold(i,J,k) = dv + tauNLup = tauNLdn + + ! diagnostics + Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG) + tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2) + !omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) + !omega_tau2w = omega_tau2x - omega_w2x_v(i,J) + if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tau2w + enddo + + do k= kbld+1, nz + vi(i,J,k) = vold(i,J,k) + vold(i,J,k) = 0.0 + enddo + endif + enddo + enddo + + if (CS%debug) then + call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) + endif + + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) + if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) + if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) + if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) + !if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) + +end subroutine vertFPmix + +!> Returns the empirical shape-function given sigma. +real function G_sig(sigma) + real , intent(in) :: sigma !< non-dimensional normalized boundary layer depth [m] + + ! local variables + real :: p1, c2, c3 !< parameters used to fit and match empirycal shape-functions. + + ! parabola + p1 = 0.287 + ! cubic function + c2 = 1.74392 + c3 = 2.58538 + G_sig = min( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) +end function G_sig + !> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb !! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme !! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, @@ -2574,6 +2955,21 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & thickness_units, conversion=US%Z_to_m) + CS%id_FPw2x = register_diag_field('ocean_model', 'FPw2x', diag%axesT1, Time, & + 'Wind direction from x-axis','radians') + CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & + 'Stress Mag Profile (u-points)', 'm2 s-2') + CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & + 'Stress Mag Profile (v-points)', 'm2 s-2') + CS%id_FPtau2s_u = register_diag_field('ocean_model', 'FPtau2s_u', diag%axesCui, Time, & + 'stress from shear direction (u-points)', 'radians ') + CS%id_FPtau2s_v = register_diag_field('ocean_model', 'FPtau2s_v', diag%axesCvi, Time, & + 'stress from shear direction (v-points)', 'radians') + CS%id_FPtau2w_u = register_diag_field('ocean_model', 'FPtau2w_u', diag%axesCui, Time, & + 'stress from wind direction (u-points)', 'radians') + CS%id_FPtau2w_v = register_diag_field('ocean_model', 'FPtau2w_v', diag%axesCvi, Time, & + 'stress from wind direction (v-points)', 'radians') + CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_du_dt_visc > 0) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index becf1f8995..7539f05ba2 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -5,6 +5,7 @@ module MOM_CFC_cap ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : EFP_type +use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -18,15 +19,14 @@ module MOM_CFC_cap use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_mass_int_EFP -use MOM_time_manager, only : time_type -use MOM_interpolate, only : time_interp_external -use MOM_interpolate, only : external_field +use MOM_time_manager, only : time_type, increment_date +use MOM_interpolate, only : external_field, init_external_field, time_interp_external use MOM_tracer_registry, only : register_tracer use MOM_tracer_types, only : tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -34,24 +34,29 @@ module MOM_CFC_cap #include public register_CFC_cap, initialize_CFC_cap, CFC_cap_unit_tests -public CFC_cap_column_physics, CFC_cap_surface_state, CFC_cap_fluxes +public CFC_cap_column_physics, CFC_cap_set_forcing public CFC_cap_stock, CFC_cap_end integer, parameter :: NTR = 2 !< the number of tracers in this module. -!> Contains the concentration array, a pointer to Tr in Tr_reg, and some metadata for a single CFC tracer +!> Contains the concentration array, surface flux, a pointer to Tr in Tr_reg, +!! and some metadata for a single CFC tracer type, private :: CFC_tracer_data - type(vardesc) :: desc !< A set of metadata for the tracer - real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. - real :: land_val = -1.0 !< The value of the tracer used where land is masked out [mol kg-1]. - character(len=32) :: name !< Tracer variable name - integer :: id_cmor !< Diagnostic ID - real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. - type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg - end type CFC_tracer_data + type(vardesc) :: desc !< A set of metadata for the tracer + real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. + real :: land_val = -1.0 !< The value of the tracer used where land is + !! masked out [mol kg-1]. + character(len=32) :: name !< Tracer variable name + integer :: id_cmor = -1 !< Diagnostic id + integer :: id_sfc_flux = -1 !< Surface flux id + real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. + real, pointer, dimension(:,:) :: sfc_flux !< Surface flux [CU R Z T-1 ~> mol m-2 s-1] + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg +end type CFC_tracer_data !> The control structure for the CFC_cap tracer package type, public :: CFC_cap_CS ; private + logical :: debug !< If true, write verbose checksums for debugging purposes. character(len=200) :: IC_file !< The file in which the CFC initial values can !! be found, or an empty string for internal initilaization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. @@ -63,7 +68,12 @@ module MOM_CFC_cap !! the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure - type(CFC_tracer_data), dimension(2) :: CFC_data !< per-tracer parameters / metadata + type(CFC_tracer_data), dimension(NTR) :: CFC_data !< per-tracer parameters / metadata + integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file + type(external_field) :: cfc11_atm_nh_handle !< Handle for time-interpolated CFC11 atm NH + type(external_field) :: cfc11_atm_sh_handle !< Handle for time-interpolated CFC11 atm SH + type(external_field) :: cfc12_atm_nh_handle !< Handle for time-interpolated CFC12 atm NH + type(external_field) :: cfc12_atm_sh_handle !< Handle for time-interpolated CFC12 atm SH end type CFC_cap_CS contains @@ -82,14 +92,17 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "MOM_CFC_cap" ! This module's name. - character(len=200) :: inputdir ! The directory where NetCDF input files are. ! This include declares and sets the variable "version". # include "version_variable.h" + character(len=200) :: inputdir ! The directory where NetCDF input files are. real, dimension(:,:,:), pointer :: tr_ptr => NULL() - character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. + character(len=200) :: CFC_BC_file ! filename with cfc11 and cfc12 data + character(len=30) :: CFC_BC_var_name ! varname of field in CFC_BC_file character :: m2char logical :: register_CFC_cap integer :: isd, ied, jsd, jed, nz, m + integer :: CFC_BC_data_year ! specific year in CFC BC data calendar + integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -101,15 +114,19 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") - if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file, '/') == 0)) then ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file, & + "full path of CFC_IC_FILE") endif call get_param(param_file, mdl, "CFC_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, CFC_IC_FILE is in depth space, not layer space", & @@ -119,7 +136,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) "if they are not found in the restart files. Otherwise "//& "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) - do m=1,2 + do m=1,NTR write(m2char, "(I1)") m call get_param(param_file, mdl, "CFC1"//m2char//"_IC_VAL", CS%CFC_data(m)%IC_val, & "Value that CFC_1"//m2char//" is set to when it is not read from a file.", & @@ -128,28 +145,50 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! the following params are not used in this module. Instead, they are used in ! the cap but are logged here to keep all the CFC cap params together. - call get_param(param_file, mdl, "CFC_BC_FILE", dummy, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ") - if ((len_trim(dummy) > 0) .and. (scan(dummy,'/') == 0)) then - ! Add the directory if dummy is not already a complete path. - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - dummy = trim(slasher(inputdir))//trim(dummy) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", dummy) + call get_param(param_file, mdl, "CFC_BC_FILE", CFC_BC_file, & + "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& + "found (units must be parts per trillion).", default=" ") + if (len_trim(CFC_BC_file) == 0) then + call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") endif - if (len_trim(dummy) > 0) then - call get_param(param_file, mdl, "CFC11_VARIABLE", dummy, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11") - call get_param(param_file, mdl, "CFC12_VARIABLE", dummy, & - "The name of the variable representing CFC-12 in "//& - "CFC_BC_FILE.", default="CFC_12") + if (scan(CFC_BC_file, '/') == 0) then + ! Add the directory if CFC_BC_file is not already a complete path. + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + CFC_BC_file = trim(slasher(inputdir))//trim(CFC_BC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", CFC_BC_file, & + "full path of CFC_BC_FILE") endif + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & + "Specific year in CFC_BC_FILE data calendar", default=2000) + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & + "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year + + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh") + CS%cfc11_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh") + CS%cfc11_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh") + CS%cfc12_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh") + CS%cfc12_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) +! domain=G%Domain%mpp_domain) + ! The following vardesc types contain a package of metadata about each tracer, ! including, the name; units; longname; and grid information. - do m=1,2 + do m=1,NTR write(m2char, "(I1)") m write(CS%CFC_data(m)%name, "(2A)") "CFC_1", m2char CS%CFC_data(m)%desc = var_desc(CS%CFC_data(m)%name, & @@ -158,6 +197,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) caller=mdl) allocate(CS%CFC_data(m)%conc(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%CFC_data(m)%sfc_flux(isd:ied,jsd:jed), source=0.0) ! This pointer assignment is needed to force the compiler not to do a copy in ! the registration calls. Curses on the designers and implementers of F90. @@ -202,7 +242,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) CS%Time => day CS%diag => diag - do m=1,2 + do m=1,NTR if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp))) then call init_tracer_CFC(h, CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%CFC_data(m)%land_val, & @@ -211,11 +251,24 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) endif ! cmor diagnostics + ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] ! CFC11 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/42625c97b8fe75124a345962c4430982.html + ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html + ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html write(m2char, "(I1)") m - CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', 'cfc1'//m2char, diag%axesTL, day, & - 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', conversion=GV%Rho0*US%R_to_kg_m3) + CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', & + 'cfc1'//m2char, diag%axesTL, day, & + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', & + conversion=GV%Rho0*US%R_to_kg_m3) + + CS%CFC_data(m)%id_sfc_flux = register_diag_field('ocean_model', & + 'cfc1'//m2char//'_flux', diag%axesT1, day, & + 'Gas exchange flux of CFC1'//m2char//' into the ocean ', & + 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + cmor_field_name='fgcfc1'//m2char, & + cmor_long_name='Surface Downward CFC1'//m2char//' Flux', & + cmor_standard_name='surface_downward_cfc1'//m2char//'_flux') enddo @@ -308,7 +361,8 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - integer :: i, j, k, is, ie, js, je, nz + real :: flux_scale + integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -317,39 +371,45 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Compute KPP nonlocal term if necessary if (present(KPP_CSp)) then if (associated(KPP_CSp) .and. present(nonLocalTrans)) then - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc11_flux(:,:), dt, CS%diag, & - CS%CFC_data(1)%tr_ptr, CS%CFC_data(1)%conc(:,:,:), & - flux_scale=GV%RZ_to_H) - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc12_flux(:,:), dt, CS%diag, & - CS%CFC_data(2)%tr_ptr, CS%CFC_data(2)%conc(:,:,:), & - flux_scale=GV%RZ_to_H) + flux_scale = GV%Z_to_H / GV%rho0 + + do m=1,NTR + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, & + CS%CFC_data(m)%sfc_flux(:,:), dt, CS%diag, & + CS%CFC_data(m)%tr_ptr, CS%CFC_data(m)%conc(:,:,:), & + flux_scale=flux_scale) + enddo endif endif ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - 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 - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(1)%conc, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(1)%conc, G, GV, sfc_flux=fluxes%cfc11_flux) - - 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 - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(2)%conc, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(2)%conc, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,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 + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(m)%conc, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo else - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(1)%conc, G, GV, sfc_flux=fluxes%cfc11_flux) - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(2)%conc, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo endif ! If needed, write out any desired diagnostics from tracer sources & sinks here. - if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, CS%CFC_data(1)%conc, CS%diag) - if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, CS%CFC_data(2)%conc, CS%diag) + do m=1,NTR + if (CS%CFC_data(m)%id_cmor > 0) & + call post_data(CS%CFC_data(m)%id_cmor, & + (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(m)%conc, CS%diag) + + if (CS%CFC_data(m)%id_sfc_flux > 0) & + call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) + enddo end subroutine CFC_cap_column_physics @@ -388,96 +448,72 @@ function CFC_cap_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif - do m=1,2 + do m=1,NTR call query_vardesc(CS%CFC_data(m)%desc, name=names(m), units=units(m), caller="CFC_cap_stock") units(m) = trim(units(m))//" kg" stocks(m) = global_mass_int_EFP(h, G, GV, CS%CFC_data(m)%conc, on_PE_only=.true.) enddo - CFC_cap_stock = 2 + CFC_cap_stock = NTR end function CFC_cap_stock -!> Extracts the ocean surface CFC concentrations and copies them to sfc_state. -subroutine CFC_cap_surface_state(sfc_state, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(CFC_cap_CS), pointer :: CS!< The control structure returned by a previous - !! call to register_CFC_cap. - - ! Local variables - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (.not.associated(CS)) return - - do j=js,je ; do i=is,ie - sfc_state%sfc_cfc11(i,j) = CS%CFC_data(1)%conc(i,j,1) - sfc_state%sfc_cfc12(i,j) = CS%CFC_data(2)%conc(i,j,1) - enddo ; enddo - -end subroutine CFC_cap_surface_state - !> Orchestrates the calculation of the CFC fluxes [mol m-2 s-1], including getting the ATM !! concentration, and calculating the solubility, Schmidt number, and gas exchange. -subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, & - cfc11_atm_handle, cfc12_atm_handle) - 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(surface), intent(in ) :: sfc_state !< A structure containing fields - !! that describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing pointers - !! to thermodynamic and tracer forcing fields. Unused fields - !! have NULL ptrs. - real, intent(in ) :: Rho0 !< The mean ocean density [R ~> kg m-3] - type(time_type), intent(in ) :: Time !< The time of the fluxes, used for interpolating the - !! CFC's concentration in the atmosphere. - type(external_field), optional, intent(inout) :: cfc11_atm_handle !< Handle for time-interpolated CFC11 - type(external_field), optional, intent(inout) :: cfc12_atm_handle !< Handle for time-interpolated CFC12 +subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) + type(surface), intent(in ) :: sfc_state !< A structure containing fields + !! that describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers + !! to thermodynamic and tracer forcing fields. Unused fields + !! have NULL ptrs. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(time_type), intent(in) :: day_interval !< Length of time over which these + !! fluxes will be applied. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. ! Local variables + type(time_type) :: Time_external ! time value used in CFC_BC_file real, dimension(SZI_(G),SZJ_(G)) :: & kw_wo_sc_no_term, & ! gas transfer velocity, without the Schmidt number term [Z T-1 ~> m s-1]. - kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. - cair, & ! The surface gas concentration in equilibrium with the atmosphere (saturation concentration) - ! [mol kg-1]. - cfc11_atm, & !< CFC11 concentration in the atmopshere [pico mol/mol] - cfc12_atm !< CFC11 concentration in the atmopshere [pico mol/mol] - real :: ta ! Absolute sea surface temperature [hectoKelvin] - real :: sal ! Surface salinity [PSU]. - real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. - real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. - real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. - real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. + cair, & ! The surface gas concentration in equilibrium with the atmosphere + ! (saturation concentration) [mol kg-1]. + cfc11_atm, & ! CFC11 atm mole fraction [pico mol/mol] + cfc12_atm ! CFC12 atm mole fraction [pico mol/mol] + real :: cfc11_atm_nh ! NH value for cfc11_atm + real :: cfc11_atm_sh ! SH value for cfc11_atm + real :: cfc12_atm_nh ! NH value for cfc12_atm + real :: cfc12_atm_sh ! SH value for cfc12_atm + real :: ta ! Absolute sea surface temperature [hectoKelvin] + real :: sal ! Surface salinity [PSU]. + real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. - real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] - integer :: i, j, is, ie, js, je + real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] + integer :: i, j, is, ie, js, je, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - ! CFC11 ATM concentration - if (present(cfc11_atm_handle)) then - call time_interp_external(cfc11_atm_handle, Time, cfc11_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc11_atm = cfc11_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc11_atm internally" //& - "has not been implemented yet.") - endif + ! Time_external = increment_date(day_start + day_interval/2, years=CS%CFC_BC_year_offset) + Time_external = increment_date(day_start, years=CS%CFC_BC_year_offset) - ! CFC12 ATM concentration - if (present(cfc12_atm_handle)) then - call time_interp_external(cfc12_atm_handle, Time, cfc12_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc12_atm = cfc12_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc12_atm internally" //& - "has not been implemented yet.") - endif + ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc11_atm_nh_handle, Time_external, cfc11_atm_nh) + cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc11_atm_sh_handle, Time_external, cfc11_atm_sh) + cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 + + ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(CS%cfc12_atm_nh_handle, Time_external, cfc12_atm_nh) + cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 + call time_interp_external(CS%cfc12_atm_sh_handle, Time_external, cfc12_atm_sh) + cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 !--------------------------------------------------------------------- ! Gas exchange/piston velocity parameter @@ -489,6 +525,21 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, & ! set unit conversion factors press_to_atm = US%R_to_kg_m3*US%L_T_to_m_s**2 * pa_to_atm + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) < -10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + cfc12_atm(i,j) = cfc12_atm_sh + elseif (G%geoLatT(i,j) <= 10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc11_atm_nh - cfc11_atm_sh) + cfc12_atm(i,j) = cfc12_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc12_atm_nh - cfc12_atm_sh) + else + cfc11_atm(i,j) = cfc11_atm_nh + cfc12_atm(i,j) = cfc12_atm_nh + endif + enddo ; enddo + do j=js,je ; do i=is,ie ! ta in hectoKelvin ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) @@ -507,14 +558,21 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, & ! CFC flux units: CU R Z T-1 = mol kg-1 R Z T-1 ~> mol m-2 s-1 kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_11) cair(i,j) = press_to_atm * alpha_11 * cfc11_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc11_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC11(i,j)) * Rho0 + CS%CFC_data(1)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(1)%conc(i,j,1)) * Rho0 kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_12) cair(i,j) = press_to_atm * alpha_12 * cfc12_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc12_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC12(i,j)) * Rho0 + CS%CFC_data(2)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(2)%conc(i,j,1)) * Rho0 enddo ; enddo -end subroutine CFC_cap_fluxes + if (CS%debug) then + do m=1,NTR + call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & + scale=US%RZ_T_to_kg_m2s) + enddo + endif + +end subroutine CFC_cap_set_forcing !> Calculates the CFC's solubility function following Warner and Weiss (1985) DSR, vol 32. subroutine get_solubility(alpha_11, alpha_12, ta, sal , mask) @@ -601,8 +659,9 @@ subroutine CFC_cap_end(CS) integer :: m if (associated(CS)) then - do m=1,2 + do m=1,NTR if (associated(CS%CFC_data(m)%conc)) deallocate(CS%CFC_data(m)%conc) + if (associated(CS%CFC_data(m)%sfc_flux)) deallocate(CS%CFC_data(m)%sfc_flux) enddo deallocate(CS) @@ -679,7 +738,7 @@ logical function compare_values(verbose, test_name, calc, ans, limit) write(stdout,10) calc, ans endif -10 format("calc=",f20.16," ans",f20.16) +10 format("calc=",f22.16," ans",f22.16) end function compare_values !> \namespace mom_CFC_cap diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 similarity index 75% rename from src/tracer/MOM_lateral_boundary_diffusion.F90 rename to src/tracer/MOM_hor_bnd_diffusion.F90 index f26395c119..4f6f198ff8 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -1,7 +1,7 @@ -!> Calculates and applies diffusive fluxes as a parameterization of lateral mixing (non-neutral) by +!> Calculates and applies diffusive fluxes as a parameterization of horizontal mixing (non-neutral) by !! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. -module MOM_lateral_boundary_diffusion +module MOM_hor_bnd_diffusion ! This file is part of MOM6. See LICENSE.md for the license. @@ -28,18 +28,19 @@ module MOM_lateral_boundary_diffusion implicit none ; private -public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init -public boundary_k_range +public near_boundary_unit_tests, hor_bnd_diffusion, hor_bnd_diffusion_init +public boundary_k_range, hor_bnd_diffusion_end ! Private parameters to avoid doing string comparisons for bottom or top boundary layer integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include -!> Sets parameters for lateral boundary mixing module. -type, public :: lbd_CS ; private +!> Sets parameters for horizontal boundary mixing module. +type, public :: hbd_CS ; private logical :: debug !< If true, write verbose checksums for debugging. integer :: deg !< Degree of polynomial reconstruction. + integer :: hbd_nk !< Maximum number of levels in the HBD grid [nondim] integer :: surface_boundary_scheme !< Which boundary layer scheme to use !! 1. ePBL; 2. KPP logical :: limiter !< Controls whether a flux limiter is applied in the @@ -51,50 +52,59 @@ module MOM_lateral_boundary_diffusion real :: H_subroundoff !< A thickness that is so small that it can be added to a thickness of !! Angstrom or larger without changing it at the bit level [H ~> m or kg m-2]. !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. + ! HBD dynamic grids + real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjecent to + !! u-points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to + !! v-points (left and right) [H ~> m or kg m-2] + integer, allocatable, dimension(:,:) :: hbd_u_kmax !< Maximum vertical index in hbd_grd_u [nondim] + integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim] type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. -end type lbd_CS +end type hbd_CS ! This include declares and sets the variable "version". #include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module -integer :: id_clock_lbd !< CPU clock for lbd +character(len=40) :: mdl = "MOM_hor_bnd_diffusion" !< Name of this module +integer :: id_clock_hbd !< CPU clock for hbd contains !> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be -!! needed for lateral boundary diffusion. -logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, CS) +!! needed for horizontal boundary diffusion. +logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, CS) type(time_type), target, intent(in) :: Time !< Time structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD - type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure + type(hbd_CS), pointer :: CS !< Horizontal boundary mixing control structure ! local variables character(len=80) :: string ! Temporary strings - logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code + logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then - call MOM_error(FATAL, "lateral_boundary_diffusion_init called with associated control structure.") + call MOM_error(FATAL, "hor_bnd_diffusion_init called with associated control structure.") return endif ! Log this module and master switch for turning it on/off - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & default=.false., do_not_log=.true.) call log_version(param_file, mdl, version, & - "This module implements lateral diffusion of tracers near boundaries", & - all_default=.not.lateral_boundary_diffusion_init) - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & - "If true, enables the lateral boundary tracer's diffusion module.", & + "This module implements horizontal diffusion of tracers near boundaries", & + all_default=.not.hor_bnd_diffusion_init) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + "If true, enables the horizonal boundary tracer's diffusion module.", & default=.false.) - if (.not. lateral_boundary_diffusion_init) return + if (.not. hor_bnd_diffusion_init) return allocate(CS) CS%diag => diag @@ -102,57 +112,66 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + ! max. number of vertical layers + CS%hbd_nk = 2 + (GV%ke*2) + ! allocate the hbd grids and k_max + allocate(CS%hbd_grd_u(SZIB_(G),SZJ_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_grd_v(SZI_(G),SZJB_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(SZIB_(G),SZJ_(G)), source=0) + allocate(CS%hbd_v_kmax(SZI_(G),SZJB_(G)), source=0) + CS%surface_boundary_scheme = -1 if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then - call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Horizontal boundary diffusion is true, but no valid boundary layer scheme was found") endif ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & + call get_param(param_file, mdl, "HBD_LINEAR_TRANSITION", CS%linear, & "If True, apply a linear transition at the base/top of the boundary. \n"//& "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & "If True, apply a flux limiter in the native grid.", default=.true.) call get_param(param_file, mdl, "APPLY_LIMITER_REMAP", CS%limiter_remap, & "If True, apply a flux limiter in the remapped grid.", default=.false.) - call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & - "Use boundary extrapolation in LBD code", & + call get_param(param_file, mdl, "HBD_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in HBD code", & default=.false.) - call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & + call get_param(param_file, mdl, "HBD_REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - !### Revisit this hard-coded answer_date. + + ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false., answer_date=20190101) + check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - call get_param(param_file, mdl, "LBD_DEBUG", CS%debug, & - "If true, write out verbose debugging data in the LBD module.", & - default=.false.) + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & + "If true, write out verbose debugging data in the HBD module.", & + default=debug) - id_clock_lbd = cpu_clock_id('(Ocean LBD)', grain=CLOCK_MODULE) + id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) -end function lateral_boundary_diffusion_init +end function hor_bnd_diffusion_init -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. +!> Driver routine for calculating horizontal diffusive fluxes near the top and bottom boundaries. !! Diffusion is applied using only information from neighboring cells, as follows: -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F -subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) - type(ocean_grid_type), intent(inout) :: G !< Grid type - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts - !! (I_numitts in tracer_hordiff) [T ~> s] - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lbd_CS), pointer :: CS !< Control structure for this module +subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) [T ~> s] + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(hbd_CS), pointer :: CS !< Control structure for this module ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -168,28 +187,32 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, !! only used to compute tendencies. - real :: tracer_int_prev !< Globally integrated tracer before LBD is applied, in mks units [conc kg] - real :: tracer_int_end !< Integrated tracer after LBD is applied, in mks units [conc kg] + real :: tracer_int_prev !< Globally integrated tracer before HBD is applied, in mks units [conc kg] + real :: tracer_int_end !< Integrated tracer after HBD is applied, in mks units [conc kg] real :: Idt !< inverse of the time step [T-1 ~> s-1] character(len=256) :: mesg !< Message for error messages. integer :: i, j, k, m !< indices to loop over - call cpu_clock_begin(id_clock_lbd) + call cpu_clock_begin(id_clock_hbd) Idt = 1./dt if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & m_to_MLD_units=GV%m_to_H) call pass_var(hbl,G%Domain) + + ! build HBD grid + call hbd_grid(SURFACE, G, GV, hbl, h, CS) + do m = 1,Reg%ntr ! current tracer tracer => Reg%tr(m) if (CS%debug) then - call hchksum(tracer%t, "before LBD "//tracer%name,G%HI) + call hchksum(tracer%t, "before HBD "//tracer%name,G%HI) endif ! for diagnostics - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 .or. CS%debug) then + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 .or. CS%debug) then tendency(:,:,:) = 0.0 tracer_old(:,:,:) = tracer%t(:,:,:) endif @@ -198,13 +221,14 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) uFlx(:,:,:) = 0. vFlx(:,:,:) = 0. - ! LBD layer by layer + ! HBD layer by layer do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + call fluxes_layer_method(SURFACE, GV%ke, hbl(I,j), hbl(I+1,j), & h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & - Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) + Coef_x(I,j,:), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & + CS%hbd_grd_u(I,j,:), CS) endif enddo enddo @@ -213,7 +237,8 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dCv(i,J)>0.) then call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & - Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) + Coef_y(i,J,:), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & + CS%hbd_grd_v(i,J,:), CS) endif enddo enddo @@ -224,7 +249,7 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 ) then tendency(i,j,k) = ((uFlx(I-1,j,k)-uFlx(I,j,k)) + (vFlx(i,J-1,k)-vFlx(i,J,k))) * & G%IareaT(i,j) * Idt endif @@ -239,64 +264,131 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) endif if (CS%debug) then - call hchksum(tracer%t, "after LBD "//tracer%name,G%HI) - ! tracer (native grid) integrated tracer amounts before and after LBD + call hchksum(tracer%t, "after HBD "//tracer%name,G%HI) + ! tracer (native grid) integrated tracer amounts before and after HBD tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) tracer_int_end = global_mass_integral(h, G, GV, tracer%t) - write(mesg,*) 'Total '//tracer%name//' before/after LBD:', tracer_int_prev, tracer_int_end + write(mesg,*) 'Total '//tracer%name//' before/after HBD:', tracer_int_prev, tracer_int_end call MOM_mesg(mesg) endif ! Post the tracer diagnostics - if (tracer%id_lbd_dfx>0) call post_data(tracer%id_lbd_dfx, uFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfx_2d>0) then + if (tracer%id_hbd_dfx>0) call post_data(tracer%id_hbd_dfx, uFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfy>0) call post_data(tracer%id_hbd_dfy, vFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfx_2d>0) then uwork_2d(:,:) = 0. do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) + call post_data(tracer%id_hbd_dfx_2d, uwork_2d, CS%diag) endif - if (tracer%id_lbd_dfy_2d>0) then + if (tracer%id_hbd_dfy_2d>0) then vwork_2d(:,:) = 0. do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) + call post_data(tracer%id_hbd_dfy_2d, vwork_2d, CS%diag) endif ! post tendency of tracer content - if (tracer%id_lbdxy_cont > 0) then - call post_data(tracer%id_lbdxy_cont, tendency, CS%diag) + if (tracer%id_hbdxy_cont > 0) then + call post_data(tracer%id_hbdxy_cont, tendency, CS%diag) endif ! post depth summed tendency for tracer content - if (tracer%id_lbdxy_cont_2d > 0) then + if (tracer%id_hbdxy_cont_2d > 0) then tendency_2d(:,:) = 0. do j=G%jsc,G%jec ; do i=G%isc,G%iec do k=1,GV%ke tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) enddo enddo ; enddo - call post_data(tracer%id_lbdxy_cont_2d, tendency_2d, CS%diag) + call post_data(tracer%id_hbdxy_cont_2d, tendency_2d, CS%diag) endif ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array and its units. - if (tracer%id_lbdxy_conc > 0) then + if (tracer%id_hbdxy_conc > 0) then do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + CS%H_subroundoff ) enddo ; enddo ; enddo - call post_data(tracer%id_lbdxy_conc, tendency, CS%diag) + call post_data(tracer%id_hbdxy_conc, tendency, CS%diag) endif enddo - call cpu_clock_end(id_clock_lbd) + call cpu_clock_end(id_clock_hbd) -end subroutine lateral_boundary_diffusion +end subroutine hor_bnd_diffusion + +!> Build the HBD grid where tracers will be rammaped to. +subroutine hbd_grid(boundary, G, GV, hbl, h, CS) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(:,:,:) = 0.0 + CS%hbd_grd_v(:,:,:) = 0.0 + CS%hbd_u_kmax(:,:) = 0 + CS%hbd_v_kmax(:,:) = 0 + + do j=G%jsc,G%jec + do I=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call merge_interfaces(GV%ke, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, u-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(I,j) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(I,j,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call merge_interfaces(GV%ke, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + CS%H_subroundoff, dz_top) + + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, v-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_v_kmax(i,J) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_v(i,J,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + +end subroutine hbd_grid !> Calculate the harmonic mean of two quantities !! See \ref section_harmonic_mean. @@ -511,6 +603,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b ! Local variables real :: htot ! Summed thickness [H ~> m or kg m-2] integer :: k + ! Surface boundary layer if ( boundary == SURFACE ) then k_top = 1 @@ -532,6 +625,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b return endif enddo + ! Bottom boundary layer elseif ( boundary == BOTTOM ) then k_top = nk @@ -559,10 +653,10 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!> Calculate the horizontal boundary diffusive fluxes using the layer by layer method. !! See \ref section_method subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, area_L, area_R, CS) + khtr_u, F_layer, area_L, area_R, nk, dz_top, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] @@ -574,29 +668,29 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step - !! at a velocity point [L2 ~> m2] + real, dimension(ke+1),intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point and vertical interfaces [L2 ~> m2] real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! in the native grid [H L2 conc ~> m3 conc] real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure + integer, intent(in ) :: nk !< Number of layers in the HBD grid [nondim] + real, dimension(nk), intent(in ) :: dz_top !< The HBD z grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure ! Local variables - real, allocatable :: dz_top(:) !< The LBD z grid to be created [H ~> m or kg m-2] real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] - real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid + real, allocatable :: khtr_ul_z(:) !< khtr_u at layer centers in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(ke) :: h_vel !< Thicknesses at u- and v-points in the native grid !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real, dimension(ke) :: khtr_ul !< khtr_u at the vertical layer of the native grid [L2 ~> m2] real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k + integer :: k !< Index used in the vertical direction integer :: k_bot_min !< Minimum k-index for the bottom integer :: k_bot_max !< Maximum k-index for the bottom integer :: k_bot_diff !< Difference between bottom left and right k-indices - !integer :: k_top_max !< Minimum k-index for the top - !integer :: k_top_min !< Maximum k-index for the top - !integer :: k_top_diff !< Difference between top left and right k-indices integer :: k_top_L, k_bot_L !< k-indices left native grid integer :: k_top_R, k_bot_R !< k-indices right native grid real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -604,24 +698,21 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !! layer depth in the native grid [nondim] real :: wgt !< weight to be used in the linear transition to the interior [nondim] - real :: a !< coefficient to be used in the linear transition to the interior [nondim] + real :: a !< coefficient used in the linear transition to the interior [nondim] real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] - integer :: nk !< number of layers in the LBD grid F_layer(:) = 0.0 + khtr_ul(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif - ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - nk = SIZE(dz_top) - ! allocate arrays allocate(phi_L_z(nk), source=0.0) allocate(phi_R_z(nk), source=0.0) allocate(F_layer_z(nk), source=0.0) + allocate(khtr_ul_z(nk), source=0.0) ! remap tracer to dz_top call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & @@ -629,6 +720,18 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & CS%H_subroundoff, CS%H_subroundoff) + ! thicknesses at velocity points & khtr_u at layer centers + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + ! GMM, writting 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover + ! answers with depth-independent khtr + khtr_ul(k) = khtr_u(k) + 0.5 * (khtr_u(k+1) - khtr_u(k)) + enddo + + ! remap khtr_ul to khtr_ul_z + call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + ! Calculate vertical indices containing the boundary layer in dz_top call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -642,7 +745,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ if ((CS%linear) .and. (k_bot_diff > 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo @@ -655,46 +758,21 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ htot = 0. do k = k_bot_min+1,k_bot_max, 1 wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) * wgt htot = htot + dz_top(k) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo else do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo endif endif -! TODO, boundary == BOTTOM -! if (boundary == BOTTOM) then -! ! TODO: GMM add option to apply linear decay -! k_top_max = MAX(k_top_L, k_top_R) -! ! make sure left and right k indices span same range -! if (k_top_max /= k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max /= k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! ! tracer flux where the minimum BLD intersets layer -! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) -! -! do k = k_top_max+1,nk -! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) -! enddo -! endif - - ! thicknesses at velocity points - do k = 1,ke - h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - enddo + !GMM, TODO: boundary == BOTTOM ! remap flux to h_vel (native grid) call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), F_layer(:)) @@ -723,10 +801,10 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! deallocated arrays - deallocate(dz_top) deallocate(phi_L_z) deallocate(phi_R_z) deallocate(F_layer_z) + deallocate(khtr_ul_z) end subroutine fluxes_layer_method @@ -740,7 +818,7 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real :: khtr_u ! Horizontal diffusivities at U-point [m2 s-1] + real, dimension(nk+1) :: khtr_u ! Horizontal diffusivities at U-point and interfaces[m2 s-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] character(len=120) :: test_name ! Title of the unit test @@ -748,7 +826,7 @@ logical function near_boundary_unit_tests( verbose ) real :: zeta_top ! Nondimension position [nondim] integer :: k_bot ! Index of cell containing bottom of boundary real :: zeta_bot ! Nondimension position [nondim] - type(lbd_CS), pointer :: CS + type(hbd_CS), pointer :: CS allocate(CS) ! fill required fields in CS @@ -760,9 +838,11 @@ logical function near_boundary_unit_tests( verbose ) CS%debug=.false. CS%limiter=.false. CS%limiter_remap=.false. - + CS%hbd_nk = 2 + (2*2) + allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(1,1), source=0) near_boundary_unit_tests = .false. - write(stdout,*) '==== MOM_lateral_boundary_diffusion =======================' + write(stdout,*) '==== MOM_hor_bnd_diffusion =======================' ! Unit tests for boundary_k_range test_name = 'Surface boundary spans the entire top cell' @@ -916,9 +996,10 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2.; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) @@ -926,9 +1007,10 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2.; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/2.,1./) ; phi_R = (/1.,1./) - khtr_u = 0.5 + khtr_u = (/0.5,0.5,0.5/) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) @@ -936,9 +1018,10 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2; hbl_R = 2 h_L = (/1.,2./) ; h_R = (/1.,2./) phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - khtr_u = 2. + khtr_u = (/2.,2.,2./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) @@ -946,9 +1029,10 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 12; hbl_R = 20 h_L = (/6.,6./) ; h_R = (/10.,10./) phi_L = (/1.,1./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) @@ -957,10 +1041,10 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 15; hbl_R = 10. h_L = (/10.,5./) ; h_R = (/10.,0./) phi_L = (/1.,1./) ; phi_R = (/0.,0./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) @@ -983,7 +1067,7 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) do k=1,nk if ( F_calc(k) /= F_ans(k) ) then test_layer_fluxes = .true. - write(stdout,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name + write(stdout,*) "MOM_hor_bnd_diffusion, UNIT TEST FAILED: ", test_name write(stdout,10) k, F_calc(k), F_ans(k) elseif (verbose) then write(stdout,10) k, F_calc(k), F_ans(k) @@ -1026,13 +1110,55 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range -!> \namespace mom_lateral_boundary_diffusion +!> Same as hbd_grid, but only used in the unit tests. +subroutine hbd_grid_test(boundary, hbl_L, hbl_R, h_L, h_R, CS) + integer, intent(in) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + real, intent(in) :: hbl_L !< Boundary layer depth, left [H ~> m or kg m-2] + real, intent(in) :: hbl_R !< Boundary layer depth, right [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_L !< Layer thickness in the native grid, left [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_R !< Layer thickness in the native grid, right [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(1,1,:) = 0.0 + CS%hbd_u_kmax(1,1) = 0 + + call merge_interfaces(2, h_L, h_R, hbl_L, hbl_R, CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid_test, (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(1,1) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(1,1,k) = dz_top(k) + enddo + deallocate(dz_top) + +end subroutine hbd_grid_test + +!> Deallocates hor_bnd_diffusion control structure +subroutine hor_bnd_diffusion_end(CS) + type(hbd_CS), pointer :: CS !< Horizontal boundary diffusion control structure + + if (associated(CS)) deallocate(CS) + +end subroutine hor_bnd_diffusion_end + +!> \namespace mom_hor_bnd_diffusion !! -!! \section section_LBD The Lateral Boundary Diffusion (LBD) framework +!! \section section_HBD The Horizontal Boundary Diffusion (HBD) framework !! -!! The LBD framework accounts for the effects of diabatic mesoscale fluxes +!! The HBD framework accounts for the effects of diabatic mesoscale fluxes !! within surface and bottom boundary layers. Unlike the equivalent adiabatic -!! fluxes, which is applied along neutral density surfaces, LBD is purely +!! fluxes, which is applied along neutral density surfaces, HBD is purely !! horizontal. To assure that diffusive fluxes are strictly horizontal !! regardless of the vertical coordinate system, this method relies on !! regridding/remapping techniques. @@ -1040,10 +1166,10 @@ end function test_boundary_k_range !! The bottom boundary layer fluxes remain to be implemented, although some !! of the steps needed to do so have already been added and tested. !! -!! Boundary lateral diffusion is applied as follows: +!! Horizontal boundary diffusion is applied as follows: !! -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach (@ref section_method) +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach (@ref section_method) !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F !! @@ -1067,7 +1193,7 @@ end function test_boundary_k_range !! !! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: !! -!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! If HBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay !! linearly between the top interface of the layer containing the minimum boundary !! layer depth (k_bot_min) and the lower interface of the layer containing the !! maximum layer depth (k_bot_max). @@ -1091,4 +1217,4 @@ end function test_boundary_k_range !! !! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] !! -end module MOM_lateral_boundary_diffusion +end module MOM_hor_bnd_diffusion diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 720e0012b0..bbca7ca9d6 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -27,8 +27,8 @@ module MOM_neutral_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member -use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM use MOM_io, only : stdout, stderr +use MOM_hor_bnd_diffusion, only : boundary_k_range, SURFACE, BOTTOM implicit none ; private @@ -53,8 +53,21 @@ module MOM_neutral_diffusion !! density [R L2 T-2 ~> Pa] logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. !! That is, the algorithm will exclude the surface and bottom boundary layers. + logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a + !! transition zone defined using boundary layer depths. Only available when + !! interior_only=true. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. + real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + ! Coefficients used to apply tapering from neutral to horizontal direction + real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, + !! at cell interfaces + real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, + !! at cell interfaces + ! Array used when KhTh_use_ebt_struct is true + real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point [nondim] @@ -127,9 +140,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - character(len=80) :: string ! Temporary strings + character(len=80) :: string ! Temporary strings integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: boundary_extrap + logical :: debug ! If true, write verbose checksums for debugging purposes. + logical :: boundary_extrap ! Indicate whether high-order boundary + !! extrapolation should be used within boundary cells. if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -168,6 +183,16 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& "boundary layers.", default=.false.) + if (CS%interior_only) then + call get_param(param_file, mdl, "NDIFF_TAPERING", CS%tapering, & + "If true, neutral diffusion linearly decays to zero within "//& + "a transition zone defined using boundary layer depths. "//& + "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) + endif + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& @@ -228,22 +253,32 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "exiting the iterative loop to find the neutral surface", & default=10) endif + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & "Turns on verbose output for discontinuous neutral "//& - "diffusion routines.", & - default=.false.) + "diffusion routines.", default=debug) call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & "Bring down the model if a problem with heff is detected",& default=.true.) endif if (CS%interior_only) then + allocate(CS%hbl(SZI_(G),SZJ_(G)), source=0.) call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") endif + + if (CS%tapering) then + allocate(CS%coeff_l(SZK_(GV)+1), source=1.) + allocate(CS%coeff_r(SZK_(GV)+1), source=1.) + endif endif + + if (CS%KhTh_use_ebt_struct) & + allocate(CS%Coef_h(G%isd:G%ied,G%jsd:G%jed,SZK_(GV)+1), source=0.) + ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 @@ -302,7 +337,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Variables used for reconstructions real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] @@ -321,14 +355,15 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Check if hbl needs to be extracted if (CS%interior_only) then - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, CS%hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, CS%hbl, G, US, & m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) + call pass_var(CS%hbl,G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j) > 0.0) then - call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) + call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), & + zeta_bot(i,j)) endif enddo; enddo ! TODO: add similar code for BOTTOM boundary layer @@ -548,16 +583,16 @@ end subroutine neutral_diffusion_calc_coeffs !> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] !! (I_numitts in tracer_hordiff) - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] @@ -571,13 +606,13 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion ! [H L2 conc ~> m3 conc or kg conc] + real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points. type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff if (.not. CS%continuous_reconstruction) then @@ -586,6 +621,22 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif endif + if (CS%KhTh_use_ebt_struct) then + ! Compute Coef at h points + CS%Coef_h(:,:,:) = 0. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) + do k = 1, GV%ke+1 + CS%Coef_h(i,j,k) = normalize*G%mask2dT(i,j)*((Coef_x(I-1,j,k)+Coef_x(I,j,k)) + & + (Coef_y(i,J-1,k)+Coef_y(i,J,k))) + enddo + endif + enddo; enddo + call pass_var(CS%Coef_h,G%Domain) + endif + nk = GV%ke do m = 1,Reg%ntr ! Loop over tracer registry @@ -603,58 +654,193 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) vFlx(:,:,:) = 0. ! x-flux - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & - tracer%t(i,j,:), tracer%t(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + if (CS%KhTh_use_ebt_struct) then + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i+1,j,:)) + endif + enddo ; enddo endif - enddo ; enddo + else + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif ! y-flux - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & - tracer%t(i,j,:), tracer%t(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + if (CS%KhTh_use_ebt_struct) then + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i,j+1,:)) + endif + enddo ; enddo endif - enddo ; enddo + else + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + enddo ; enddo + endif + endif ! Update the tracer concentration from divergence of neutral diffusive flux components - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + Coef_y(i,J) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) - enddo - do k = 1, GV%ke - tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 - enddo + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif - if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo do k = 1, GV%ke - tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 enddo - endif - endif - enddo ; enddo + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + + endif + enddo ; enddo + endif ! Do user controlled underflow of the tracer concentrations. if (tracer%conc_underflow > 0.0) then @@ -666,30 +852,58 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfx_2d > 0) then - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - trans_x_2d(I,j) = 0. - if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 - trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) - enddo - trans_x_2d(I,j) = trans_x_2d(I,j) * Idt - endif - enddo ; enddo + + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j,1) * uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfx_2d, trans_x_2d(:,:), CS%diag) endif ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfy_2d > 0) then - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - trans_y_2d(i,J) = 0. - if (G%mask2dCv(i,J)>0.) then - do ks = 1,CS%nsurf-1 - trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) - enddo - trans_y_2d(i,J) = trans_y_2d(i,J) * Idt - endif - enddo ; enddo + + if (CS%KhTh_use_ebt_struct) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J,1) * vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfy_2d, trans_y_2d(:,:), CS%diag) endif @@ -722,6 +936,62 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) end subroutine neutral_diffusion +!> Computes linear tapering coefficients at interfaces of the left and right columns +!! within a region defined by the boundary layer depths in the two columns. +subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) + integer, intent(in) :: ne !< Number of interfaces + real, intent(in) :: bld_l !< Boundary layer depth, left column [H ~> m or kg m-2] + real, intent(in) :: bld_r !< Boundary layer depth, right column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_l !< Layer thickness, left column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_r !< Layer thickness, right column [H ~> m or kg m-2] + real, dimension(ne), intent(inout) :: coeff_l !< Tapering coefficient, left column [nondim] + real, dimension(ne), intent(inout) :: coeff_r !< Tapering coefficient, right column [nondim] + + ! Local variables + real :: min_bld, max_bld ! Min/Max boundary layer depth in two adjacent columns + integer :: dummy1 ! dummy integer + real :: dummy2 ! dummy real + integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns + real :: zeta_l, zeta_r ! dummy variables + integer :: k ! vertical index + + ! initialize coeffs + coeff_l(:) = 1.0 + coeff_r(:) = 1.0 + + ! Calculate vertical indices containing the boundary layer depths + max_bld = MAX(bld_l, bld_r) + min_bld = MIN(bld_l, bld_r) + + ! k_min + call boundary_k_range(SURFACE, ne-1, h_l, min_bld, dummy1, dummy2, k_min_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, min_bld, dummy1, dummy2, k_min_r, & + zeta_r) + + ! k_max + call boundary_k_range(SURFACE, ne-1, h_l, max_bld, dummy1, dummy2, k_max_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, max_bld, dummy1, dummy2, k_max_r, & + zeta_r) + ! left + do k=1,k_min_l + coeff_l(k) = 0.0 + enddo + do k=k_min_l+1,k_max_l+1 + coeff_l(k) = (real(k - k_min_l) + 1.0)/(real(k_max_l - k_min_l) + 2.0) + enddo + + ! right + do k=1,k_min_r + coeff_r(k) = 0.0 + enddo + do k=k_min_r+1,k_max_r+1 + coeff_r(k) = (real(k - k_min_r) + 1.0)/(real(k_max_r - k_min_r) + 2.0) + enddo + +end subroutine compute_tapering_coeffs + !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels @@ -1907,7 +2177,8 @@ end function absolute_positions !> Returns a single column of neutral diffusion fluxes of a tracer. subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & - hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge) + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge, & + coeff_l, coeff_r) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions @@ -1923,7 +2194,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral !! surfaces [H ~> m or kg m-2] - real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) + real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers + !! (conc H or conc H L2) logical, intent(in) :: continuous !< True if using continuous reconstruction real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H ~> m or kg m-2] @@ -1931,11 +2203,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for !! edge value calculations if continuous is false [H ~> m or kg m-2] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2 or nondim] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2 or nondim] + ! Local variables integer :: k_sublayer, klb, klt, krb, krt real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int - real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int + real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int, khtr_ave real, dimension(nk+1) :: Til !< Left-column interface tracer (conc, e.g. degC) real, dimension(nk+1) :: Tir !< Right-column interface tracer (conc, e.g. degC) real, dimension(nk) :: aL_l !< Left-column left edge value of tracer (conc, e.g. degC) @@ -1950,7 +2225,12 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, dimension(nk,deg+1) :: ppoly_r_coeffs_r real, dimension(nk,deg+1) :: ppoly_r_S_l real, dimension(nk,deg+1) :: ppoly_r_S_r - logical :: down_flux + logical :: down_flux, tapering + + tapering = .false. + if (present(coeff_l) .and. present(coeff_r)) tapering = .true. + khtr_ave = 1.0 + ! Setup reconstruction edge values if (continuous) then call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) @@ -1973,6 +2253,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K if (hEff(k_sublayer) == 0.) then Flx(k_sublayer) = 0. else + if (tapering) then + klb = KoL(k_sublayer+1) + klt = KoL(k_sublayer) + krb = KoR(k_sublayer+1) + krt = KoR(k_sublayer) + ! these are added in this order to preserve vertically-uniform diffusivity answers + khtr_ave = 0.25 * ((coeff_l(klb) + coeff_l(klt)) + (coeff_r(krb) + coeff_r(krt))) + endif if (continuous) then klb = KoL(k_sublayer+1) T_left_bottom = ( 1. - PiL(k_sublayer+1) ) * Til(klb) + PiL(k_sublayer+1) * Til(klb+1) @@ -1996,7 +2284,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K else dT_ave = dT_layer endif - Flx(k_sublayer) = dT_ave * hEff(k_sublayer) + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) * khtr_ave else ! Discontinuous reconstruction ! Calculate tracer values on left and right side of the neutral surface call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & @@ -2022,7 +2310,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_sublayer >= 0. .and. dT_top_int >= 0. .and. & dT_bot_int >= 0.) if (down_flux) then - Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) + Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) * khtr_ave else Flx(k_sublayer) = 0. endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index bf4988488b..c8ce2f5f75 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -45,7 +45,7 @@ module MOM_tracer_flow_control use MOM_OCMIP2_CFC, only : OCMIP2_CFC_column_physics, OCMIP2_CFC_surface_state use MOM_OCMIP2_CFC, only : OCMIP2_CFC_stock, OCMIP2_CFC_end, OCMIP2_CFC_CS use MOM_CFC_cap, only : register_CFC_cap, initialize_CFC_cap -use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_surface_state +use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_set_forcing use MOM_CFC_cap, only : CFC_cap_stock, CFC_cap_end, CFC_cap_CS use oil_tracer, only : register_oil_tracer, initialize_oil_tracer use oil_tracer, only : oil_tracer_column_physics, oil_tracer_surface_state @@ -398,7 +398,7 @@ end subroutine get_chl_from_model !> 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, CS) +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the @@ -410,6 +410,8 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G type(time_type), intent(in) :: day_interval !< Length of time over which these !! fluxes will be applied. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -418,6 +420,9 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G ! if (CS%use_ideal_age) & ! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & ! G, CS%ideal_age_tracer_CSp) + if (CS%use_CFC_cap) & + call CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, & + CS%CFC_cap_CSp) end subroutine call_tracer_set_forcing @@ -847,8 +852,6 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, US, CS) call advection_test_tracer_surface_state(sfc_state, h, G, GV, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS%OCMIP2_CFC_CSp) - if (CS%use_CFC_cap) & - call CFC_cap_surface_state(sfc_state, G, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & call MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS%MOM_generic_tracer_CSp) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 14be088e8d..6f4e5d0f90 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -3,32 +3,32 @@ module MOM_tracer_hor_diff ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, diag_ctrl -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type -use MOM_domains, only : sum_across_PEs, max_across_PEs -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : pass_vector -use MOM_debugging, only : hchksum, uvchksum -use MOM_diabatic_driver, only : diabatic_CS -use MOM_EOS, only : calculate_density, EOS_type, EOS_domain -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -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 : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_lateral_mixing_coeffs, only : VarMix_CS -use MOM_MEKE_types, only : MEKE_type -use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end -use MOM_neutral_diffusion, only : neutral_diffusion_CS -use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion -use MOM_lateral_boundary_diffusion, only : lbd_CS, lateral_boundary_diffusion_init -use MOM_lateral_boundary_diffusion, only : lateral_boundary_diffusion -use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : sum_across_PEs, max_across_PEs +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_diabatic_driver, only : diabatic_CS +use MOM_EOS, only : calculate_density, EOS_type, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +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 : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end +use MOM_neutral_diffusion, only : neutral_diffusion_CS +use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion +use MOM_hor_bnd_diffusion, only : hbd_CS, hor_bnd_diffusion_init +use MOM_hor_bnd_diffusion, only : hor_bnd_diffusion, hor_bnd_diffusion_end +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -52,6 +52,8 @@ module MOM_tracer_hor_diff real :: max_diff_CFL !< If positive, locally limit the along-isopycnal !! tracer diffusivity to keep the diffusive CFL !! locally at or below this value [nondim]. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion @@ -59,13 +61,13 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. - logical :: use_lateral_boundary_diffusion !< If true, use the lateral_boundary_diffusion module from within + logical :: use_hor_bnd_diffusion !< If true, use the hor_bnd_diffusion module from within !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. - type(lbd_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for - !! lateral boundary mixing. + type(hbd_CS), pointer :: hor_bnd_diffusion_CSp => NULL() !< Control structure for + !! horizontal boundary diffusion. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -135,19 +137,22 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real, dimension(SZI_(G),SZJ_(G)) :: & Ihdxdy, & ! The inverse of the volume or mass of fluid in a layer in a ! grid cell [H-1 L-2 ~> m-3 or kg-1]. - Kh_h, & ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. CFL, & ! A diffusive CFL number for each cell [nondim]. dTr ! The change in a tracer's concentration, in units of concentration [Conc]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Kh_h + ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZJ_(G)) :: & - khdt_x, & ! The value of Khtr*dt times the open face width divided by + khdt_x ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + khdt_y ! The value of Khtr*dt times the open face width divided by + ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & Coef_x, & ! The coefficients relating zonal tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJB_(G)) :: & - khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & Coef_y, & ! The coefficients relating meridional tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. @@ -224,12 +229,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points - Kh_loc = Kh_u(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_u(I,j,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) @@ -241,41 +246,41 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx = 0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points - Kh_loc = Kh_v(i,J)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_v(i,J,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(Kh_u(I,j,1)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(Kh_v(i,J,1)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo elseif (Resoln_scaled) then !$OMP parallel do default(shared) private(Res_fn) do j=js,je ; do I=is-1,ie Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_u(I,j,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn enddo ; enddo !$OMP parallel do default(shared) private(Res_fn) do J=js-1,je ; do i=is,ie Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_v(i,J,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn enddo ; enddo else ! Use a simple constant diffusivity. if (CS%id_KhTr_u > 0) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - Kh_u(I,j) = CS%KhTr + Kh_u(I,j,1) = CS%KhTr khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo else @@ -287,7 +292,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%id_KhTr_v > 0) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - Kh_v(i,J) = CS%KhTr + Kh_v(i,J,1) = CS%KhTr khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo else @@ -306,7 +311,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_x(I,j) > khdt_max) then khdt_x(I,j) = khdt_max if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & - Kh_u(I,j) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Kh_u(I,j,1) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) endif enddo ; enddo else @@ -323,7 +328,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_y(i,J) > khdt_max) then khdt_y(i,J) = khdt_max if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & - Kh_v(i,J) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Kh_v(i,J,1) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) endif enddo ; enddo else @@ -387,28 +392,50 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif enddo - if (CS%use_lateral_boundary_diffusion) then + if (CS%use_hor_bnd_diffusion) then - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)") call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo enddo enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo + enddo + enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + 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 do itt=1,num_itts - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary diffusion (tracer_hordiff)",itt) + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)",itt) if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & - CS%lateral_boundary_diffusion_CSp) + call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & + CS%hor_bnd_diffusion_CSp) enddo ! itt endif @@ -418,7 +445,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) ! We are assuming that neutral surfaces do not evolve (much) as a result of multiple - ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() + !horizontal diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA if (associated(tv%p_surf)) then @@ -426,14 +453,37 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online else call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) endif - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo + enddo + enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo enddo enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + 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 do itt=1,num_itts if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion (tracer_hordiff)",itt) @@ -467,13 +517,13 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif do J=js-1,je ; do i=is,ie - Coef_y(i,J) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & + Coef_y(i,J,1) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & (h(i,j,k)+h(i,j+1,k)+h_neglect) enddo ; enddo do j=js,je do I=is-1,ie - Coef_x(I,j) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & + Coef_x(I,j,1) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & (h(i,j,k)+h(i+1,j,k)+h_neglect) enddo @@ -485,25 +535,25 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online do m=1,ntr do j=js,je ; do i=is,ie dTr(i,j) = Ihdxdy(i,j) * & - ((Coef_x(I-1,j) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_x(I,j) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & - (Coef_y(i,J-1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_y(i,J) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) + ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & + (Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) enddo ; enddo if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j) & + Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J) & + Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j) & + Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J) & + Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif do j=js,je ; do i=is,ie @@ -542,43 +592,65 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! post diagnostics for 2d tracer diffusivity if (CS%id_KhTr_u > 0) then do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - call post_data(CS%id_KhTr_u, Kh_u, CS%diag, mask=G%mask2dCu) + if (CS%KhTh_use_ebt_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%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + 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) endif if (CS%id_KhTr_v > 0) then do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - call post_data(CS%id_KhTr_v, Kh_v, CS%diag, mask=G%mask2dCv) + if (CS%KhTh_use_ebt_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%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + 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) endif if (CS%id_KhTr_h > 0) then - Kh_h(:,:) = 0.0 + Kh_h(:,:,:) = 0.0 do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,1) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,1) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo + do j=js,je ; do i=is,ie normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) - Kh_h(i,j) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j)+Kh_u(I,j)) + & - (Kh_v(i,J-1)+Kh_v(i,J))) + Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + enddo + endif enddo ; enddo - call post_data(CS%id_KhTr_h, Kh_h, CS%diag, mask=G%mask2dT) + !call post_data(CS%id_KhTr_h, Kh_h, CS%diag, is_static=.false., mask=G%mask2dT) + call post_data(CS%id_KhTr_h, Kh_h, CS%diag) endif - if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & scalar_pair=.true.) - if (CS%use_neutral_diffusion) then - call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & - scalar_pair=.true.) - endif endif if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) @@ -1489,6 +1561,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR", CS%KhTr, & "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & "The scaling coefficient for along-isopycnal tracer "//& "diffusivity using a shear-based (Visbeck-like) "//& @@ -1541,10 +1617,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic diabatic_CSp, CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") - CS%use_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, & - CS%lateral_boundary_diffusion_CSp) - if (CS%use_lateral_boundary_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & - "USE_LATERAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + CS%use_hor_bnd_diffusion = hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, & + CS%hor_bnd_diffusion_CSp) + if (CS%use_hor_bnd_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_HORIZONTAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) @@ -1558,11 +1634,11 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic CS%id_KhTr_h = -1 CS%id_CFL = -1 - CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCu1, Time, & + CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCui, Time, & 'Epipycnal tracer diffusivity at zonal faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCv1, Time, & + CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCvi, Time, & 'Epipycnal tracer diffusivity at meridional faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesT1, Time, & + CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesTi, Time, & 'Epipycnal tracer diffusivity at tracer cell center', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & cmor_field_name='diftrelo', & cmor_standard_name= 'ocean_tracer_epineutral_laplacian_diffusivity', & @@ -1584,6 +1660,7 @@ subroutine tracer_hor_diff_end(CS) type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) + call hor_bnd_diffusion_end(CS%hor_bnd_diffusion_CSp) if (associated(CS)) deallocate(CS) end subroutine tracer_hor_diff_end diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 1e9b9c22b8..c01419f3f8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -358,14 +358,14 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux" , & trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux " //& + "from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + y_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional " //& + "flux from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + x_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & @@ -381,12 +381,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, "Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, "Horizontal Boundary 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, & y_cell_method='sum') - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, "Horizontal Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') endif @@ -394,8 +394,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbd_dfx > 0) call safe_alloc_ptr(Tr%lbd_dfx,IsdB,IedB,jsd,jed,nz) - if (Tr%id_lbd_dfy > 0) call safe_alloc_ptr(Tr%lbd_dfy,isd,ied,JsdB,JedB,nz) + if (Tr%id_hbd_dfx > 0) call safe_alloc_ptr(Tr%hbd_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_hbd_dfy > 0) call safe_alloc_ptr(Tr%hbd_dfy,isd,ied,JsdB,JedB,nz) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -415,22 +415,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffx", & - diag%axesCu1, Time, & - "Total Bulk Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - y_cell_method='sum') - Tr%id_lbd_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffy", & - diag%axesCv1, Time, & - "Total Bulk Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method='sum') - Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx_2d", & + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & y_cell_method='sum') - Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy_2d", & + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') @@ -438,10 +428,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_x,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) + if (Tr%id_hbd_dfx_2d > 0) call safe_alloc_ptr(Tr%hbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_hbd_dfy_2d > 0) call safe_alloc_ptr(Tr%hbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & @@ -466,7 +454,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u enddo ; enddo ; enddo endif - ! Neutral/Lateral diffusion convergence tendencies + ! Neutral/Horizontal diffusion convergence tendencies if (Tr%diag_form == 1) then Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & @@ -477,12 +465,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') else @@ -503,13 +491,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion of tracer "//& "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') endif @@ -517,8 +505,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) - Tr%id_lbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_conc_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer concentration tendency for "//trim(shortnm), & + Tr%id_hbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_conc_tendency', & + diag%axesTL, Time, "Horizontal diffusion tracer concentration tendency for "//trim(shortnm), & trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) var_lname = "Net time tendency for "//lowercase(flux_longname) diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index 51c4508db6..bdae8bcee9 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -27,20 +27,16 @@ module MOM_tracer_types real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - !### These two arrays may be allocated but are never used. - real, dimension(:,:), pointer :: lbd_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux @@ -106,12 +102,12 @@ 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_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 - integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -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 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 - integer :: id_lbdxy_cont = -1, id_lbdxy_cont_2d = -1, id_lbdxy_conc = -1 + integer :: id_hbdxy_cont = -1, id_hbdxy_cont_2d = -1, id_hbdxy_conc = -1 integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 20685d9711..71800284a6 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -113,7 +113,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/OIL_IC_FILE", CS%IC_file) endif call get_param(param_file, mdl, "OIL_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, OIL_IC_FILE is in depth space, not layer space", & diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 580e293f4f..fa7b567845 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -98,6 +98,21 @@ module MOM_wave_interface !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & KvS !< Viscosity for Stokes Drift shear [H Z T-1 ~> m2 s-1 or Pa s] + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:), public :: & + UStk_Hb !< Surface Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + VStk_Hb !< Surface Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:), public :: & + Omega_w2x !< wind direction ccw from model x- axis [nondim radians] + integer, public :: NumBands = 0 !< Number of wavenumber/frequency partitions + !! Must match the number of bands provided + !! via either coupling or file. ! The remainder of this control structure is private integer :: WaveMethod = -99 !< Options for including wave information @@ -149,18 +164,12 @@ module MOM_wave_interface real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - - integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive - !! This needs to match the number of bands provided - !! via either coupling or file. real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] real :: I_g_Earth !< The inverse of the gravitational acceleration, with dimensional rescaling !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] ! Surface Wave Dependent 1d/2d/3d vars - real, allocatable, dimension(:) :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] real, allocatable, dimension(:) :: & Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] real, allocatable, dimension(:) :: & @@ -451,6 +460,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) allocate( CS%WaveNum_Cen(CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NumBands), source=0.0 ) + allocate( CS%UStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%VStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%Omega_w2x(G%isc:G%iec,G%jsc:G%jec) , source=0.0 ) CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & @@ -466,6 +478,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands), source=0.0 ) + CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & @@ -700,6 +713,15 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo + do jj=G%jsc,G%jec + do ii=G%isc,G%iec + !CS%Omega_w2x(ii,jj) = forces%omega_w2x(ii,jj) + do b=1,CS%NumBands + CS%UStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%UStkb(ii,jj,b) + CS%VStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%VStkb(ii,jj,b) + enddo + enddo + enddo elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands do jj=G%jsd,G%jed @@ -2027,6 +2049,9 @@ subroutine Waves_end(CS) if (allocated(CS%La_turb)) deallocate( CS%La_turb ) if (allocated(CS%STKx0)) deallocate( CS%STKx0 ) if (allocated(CS%STKy0)) deallocate( CS%STKy0 ) + if (allocated(CS%UStk_Hb)) deallocate( CS%UStk_Hb ) + if (allocated(CS%VStk_Hb)) deallocate( CS%VStk_Hb ) + if (allocated(CS%Omega_w2x)) deallocate( CS%Omega_w2x ) if (allocated(CS%KvS)) deallocate( CS%KvS ) if (allocated(CS%Us0_y)) deallocate( CS%Us0_y ) if (allocated(CS%Us0_x)) deallocate( CS%Us0_x )