diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5e1da1c1f9..c22bfc4144 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -44,14 +44,14 @@ gnu:ocean-only-nolibs: tags: - ncrc4 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-oceanonly-nolibs + - make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-gnu-oceanonly-nolibs gnu:ice-ocean-nolibs: stage: builds tags: - ncrc4 script: - - make -f tools/MRS/Makefile pipeline-build-gnu-iceocean-nolibs + - make -f tools/MRS/Makefile MOM6_SRC=../.. pipeline-build-gnu-iceocean-nolibs intel:repro: stage: builds diff --git a/.testing/Makefile b/.testing/Makefile index f330c92e3b..4096436f30 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -265,9 +265,9 @@ build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp build/target/Makefile: MOM_ACFLAGS= build/opt/Makefile: MOM_ACFLAGS= build/opt_target/Makefile: MOM_ACFLAGS= -build/coupled/Makefile: MOM_ACFLAGS=--with-driver=coupled_driver -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_driver -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_driver +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 # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) diff --git a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 index acbbc292de..faa74a7fe0 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -374,7 +374,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -956,13 +956,13 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux).and.present(tauy)) then do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & taux(I,j) = (G%mask2dBu(I,J)*taux_in_B(I,J) + G%mask2dBu(I,J-1)*taux_in_B(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) enddo ; enddo do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & tauy(i,J) = (G%mask2dBu(I,J)*tauy_in_B(I,J) + G%mask2dBu(I-1,J)*tauy_in_B(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) enddo ; enddo @@ -984,14 +984,14 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, if (present(taux)) then ; do j=jsh,jeh ; do I=Isqh,Ieqh taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & taux(I,j) = (G%mask2dT(i,j)*taux_in_A(i,j) + G%mask2dT(i+1,j)*taux_in_A(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) enddo ; enddo ; endif if (present(tauy)) then ; do J=Jsqh,Jeqh ; do i=ish,ieh tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & tauy(i,J) = (G%mask2dT(i,j)*tauy_in_A(i,j) + G%mask2dT(i,J+1)*tauy_in_A(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) enddo ; enddo ; endif @@ -1029,10 +1029,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, gustiness = CS%gust_const if (CS%read_gust_2d) then if ((wind_stagger == CGRID_NE) .or. & - ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0)) .or. & + ((wind_stagger == AGRID) .and. (G%mask2dT(i,j) > 0.0)) .or. & ((wind_stagger == BGRID_NE) .and. & (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0)) ) & + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0)) ) & gustiness = CS%gust(i,j) endif ustar(i,j) = sqrt(gustiness*IRho0 + IRho0*Pa_conversion*IOB%stress_mag(i-i0,j-j0)) @@ -1050,7 +1050,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_in_B(I,J)**2 + tauy_in_B(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_in_B(I-1,J-1)**2 + tauy_in_B(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_in_B(I,J-1)**2 + tauy_in_B(I,J-1)**2) + & @@ -1069,7 +1069,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, do j=js,je ; do i=is,ie tau_mag = G%mask2dT(i,j) * sqrt(taux_in_A(i,j)**2 + tauy_in_A(i,j)**2) gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) if (do_ustar) ustar(i,j) = sqrt(gustiness*IRho0 + IRho0 * tau_mag) if (CS%answers_2018) then if (do_gustless) gustless_ustar(i,j) = sqrt(US%L_to_Z*tau_mag / CS%Rho0) @@ -1080,10 +1080,10 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, else ! C-grid wind stresses. do j=js,je ; do i=is,ie taux2 = 0.0 ; tauy2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*taux_in_C(I-1,j)**2 + G%mask2dCu(I,j)*taux_in_C(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*tauy_in_C(i,J-1)**2 + G%mask2dCv(i,J)*tauy_in_C(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) tau_mag = sqrt(taux2 + tauy2) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 97fb869ad4..21992f5833 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1001,7 +1001,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 3bd0e1e28d..11159903ab 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -689,34 +689,34 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & OS%restart_CSp, GV=OS%GV, filename=restartname) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) - endif + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif - end if + if (BTEST(OS%Restart_control,1)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, .true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif + endif end subroutine ocean_model_restart ! NAME="ocean_model_restart" @@ -1033,7 +1033,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 index 7b32270b4c..4adccfef65 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -9,7 +9,6 @@ module MOM_surface_forcing_mct use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg @@ -290,9 +289,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) @@ -310,7 +309,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) - enddo; enddo + enddo ; enddo if (restore_temp) call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) @@ -334,7 +333,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%area_surf < 0.0) then do j=js,je ; do i=is,ie work_sum(i,j) = US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo CS%area_surf = reproducing_sum(work_sum, isr, ier, jsr, jer) endif ! endif for allocation and initialization @@ -351,7 +350,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = 0.0 fluxes%vprec(i,j) = 0.0 - enddo; enddo + enddo ; enddo ! Salinity restoring logic if (restore_salinity) then @@ -361,7 +360,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 - enddo; enddo + enddo ; enddo endif if (CS%salt_restore_as_sflux) then do j=js,je ; do i=is,ie @@ -369,7 +368,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%salt_flux(i,j) = 1.e-3*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) *delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%salt_flux, G, fluxes%saltFluxGlobalScl, & @@ -385,14 +384,14 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & (CS%Rho0*CS%Flux_const) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif - enddo; enddo + enddo ; enddo if (CS%adjust_net_srestore_to_zero) then if (CS%adjust_net_srestore_by_scaling) then call adjust_area_mean_to_zero(fluxes%vprec, G, fluxes%vPrecGlobalScl, & @@ -404,7 +403,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%vPrecGlobalAdj = reproducing_sum(work_sum(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion*fluxes%vPrecGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif endif @@ -418,7 +417,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sst = sign(1.0,delta_sst)*min(abs(delta_sst),CS%max_delta_trestore) fluxes%heat_added(i,j) = G%mask2dT(i,j) * CS%trestore_mask(i,j) * & (CS%Rho0*fluxes%C_p) * delta_sst * CS%Flux_const ! W m-2 - enddo; enddo + enddo ; enddo endif ! obtain fluxes from IOB; note the staggering of indices @@ -438,26 +437,26 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! liquid runoff flux if (associated(IOB%rofl_flux)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%rofl_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%runoff)) then - fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%lrunoff(i,j) = kg_m2_s_conversion * IOB%runoff(i-i0,j-j0) * G%mask2dT(i,j) end if ! ice runoff flux if (associated(IOB%rofi_flux)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%rofi_flux(i-i0,j-j0) * G%mask2dT(i,j) else if (associated(IOB%calving)) then - fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%frunoff(i,j) = kg_m2_s_conversion * IOB%calving(i-i0,j-j0) * G%mask2dT(i,j) end if if (associated(IOB%ustar_berg)) & - fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%area_berg)) & - fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%mass_berg)) & - fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%mass_berg(i,j) = US%m_to_Z*US%kg_m3_to_R * IOB%mass_berg(i-i0,j-j0) * G%mask2dT(i,j) ! GMM, cime does not not have an equivalent for heat_content_lrunoff and ! heat_content_frunoff. I am setting these to zero for now. @@ -479,7 +478,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice and snow melt heat flux [W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = G%mask2dT(i,j) * US%W_m2_to_QRZ_T * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & @@ -523,22 +522,22 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%sw(i,j) = fluxes%sw_vis_dir(i,j) + fluxes%sw_vis_dif(i,j) + & fluxes%sw_nir_dir(i,j) + fluxes%sw_nir_dif(i,j) - enddo; enddo + enddo ; enddo ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif if (associated(IOB%salt_flux)) then @@ -559,19 +558,19 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, (fluxes%evap(i,j) + fluxes%vprec(i,j)) ) * US%L_to_m**2*G%areaT(i,j) net_FW2(i,j) = net_FW(i,j) / (US%L_to_m**2*G%areaT(i,j)) - enddo; enddo + enddo ; enddo if (CS%adjust_net_fresh_water_by_scaling) then call adjust_area_mean_to_zero(net_FW2, G, fluxes%netFWGlobalScl) do j=js,je ; do i=is,ie fluxes%vprec(i,j) = fluxes%vprec(i,j) + kg_m2_s_conversion * & (net_FW2(i,j) - net_FW(i,j)/(US%L_to_m**2*G%areaT(i,j))) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo else fluxes%netFWGlobalAdj = reproducing_sum(net_FW(:,:), isr, ier, jsr, jer) / CS%area_surf do j=js,je ; do i=is,ie fluxes%vprec(i,j) = ( fluxes%vprec(i,j) - kg_m2_s_conversion * fluxes%netFWGlobalAdj ) * G%mask2dT(i,j) - enddo; enddo + enddo ; enddo endif endif @@ -681,9 +680,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) !applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -749,19 +748,19 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) - enddo; enddo + enddo ; enddo ! ustar is required for the bulk mixed layer formulation. The background value ! of 0.02 Pa is a relatively small value intended to give reasonable behavior @@ -770,7 +769,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -779,33 +778,33 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%read_gust_2d) gustiness = CS%gust(i,j) endif forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0*tau_mag) - enddo; enddo + enddo ; enddo elseif (wind_stagger == AGRID) then call pass_vector(taux_at_h, tauy_at_h, G%Domain, To_All+Omit_Corners, stagger=AGRID, halo=1) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) - enddo; enddo + enddo ; enddo do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) - enddo; enddo + enddo ; enddo do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) 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)) - enddo; enddo + enddo ; enddo else ! C-grid wind stresses. if (G%symmetric) & @@ -814,12 +813,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) @@ -828,7 +827,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) else forces%ustar(i,j) = sqrt(CS%gust_const*Irho0 + Irho0*sqrt(taux2 + tauy2)) endif - enddo; enddo + enddo ; enddo endif ! endif for wind related fields diff --git a/config_src/drivers/mct_cap/ocn_comp_mct.F90 b/config_src/drivers/mct_cap/ocn_comp_mct.F90 index 2f7deaa716..f4b2ceed77 100644 --- a/config_src/drivers/mct_cap/ocn_comp_mct.F90 +++ b/config_src/drivers/mct_cap/ocn_comp_mct.F90 @@ -404,10 +404,8 @@ subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) if (debug .and. root_pe().eq.pe_here()) print *, "calling seq_infodata_putdata" - call seq_infodata_PutData( glb%infodata, & - ocn_nx = ni , ocn_ny = nj) - call seq_infodata_PutData( glb%infodata, & - ocn_prognostic=.true., ocnrof_prognostic=.true.) + call seq_infodata_PutData(glb%infodata, ocn_nx=ni, ocn_ny=nj) + call seq_infodata_PutData(glb%infodata, ocn_prognostic=.true., ocnrof_prognostic=.true.) if (debug .and. root_pe().eq.pe_here()) print *, "leaving ocean_init_mct" @@ -754,15 +752,15 @@ end subroutine ocn_domain_mct call seq_infodata_GetData( glb%infodata, start_type=starttype) - if ( trim(starttype) == trim(seq_infodata_start_type_start)) then - get_runtype = "initial" + if ( trim(starttype) == trim(seq_infodata_start_type_start)) then + get_runtype = "initial" else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then - get_runtype = "continue" + get_runtype = "continue" else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then - get_runtype = "branch" + get_runtype = "branch" else - write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' - call exit(0) + write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype' + call exit(0) end if return diff --git a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/mct_cap/ocn_cpl_indices.F90 index a701083c0c..3f47c01903 100644 --- a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 +++ b/config_src/drivers/mct_cap/ocn_cpl_indices.F90 @@ -172,11 +172,11 @@ subroutine cpl_indices_init(ind) ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'Foxx_swnet_afracr') do ncat = 1, ice_ncat - write(cncat,'(i2.2)') ncat - ncol = ncat+1 - ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) - ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) - ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) + write(cncat,'(i2.2)') ncat + ncol = ncat+1 + ind%x2o_frac_col(ncol) = mct_avect_indexra(x2o,'Si_ifrac_'//cncat) + ind%x2o_fracr_col(ncol) = ind%x2o_frac_col(ncol) + ind%x2o_qsw_fracr_col(ncol) = mct_avect_indexra(x2o,'PFioi_swpen_ifrac_'//cncat) enddo else mcog_ncols = 1 diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 174a659f12..806aaf033e 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -214,7 +214,7 @@ subroutine SetServices(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call NUOPC_CompSpecialize(gcomp, specLabel=model_label_Finalize, & - specRoutine=ocean_model_finalize, rc=rc) + specRoutine=ocean_model_finalize, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end subroutine SetServices @@ -286,7 +286,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value,*) dbug + read(value,*) dbug end if write(logmsg,'(i6)') dbug call ESMF_LogWrite('MOM_cap:dbug = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -296,8 +296,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - scalar_field_name = trim(value) - call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) + scalar_field_name = trim(value) + call ESMF_LogWrite('MOM_cap:ScalarFieldName = '//trim(scalar_field_name), ESMF_LOGMSG_INFO) endif scalar_field_count = 0 @@ -305,15 +305,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_count - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldCount not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_count - call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_count + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldCount not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_count + call ESMF_LogWrite('MOM_cap:ScalarFieldCount = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_nx = 0 @@ -321,15 +321,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_idx_grid_nx - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_nx - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_idx_grid_nx + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNX not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_nx + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNX = '//trim(logmsg), ESMF_LOGMSG_INFO) endif scalar_field_idx_grid_ny = 0 @@ -337,15 +337,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(value, *, iostat=iostat) scalar_field_idx_grid_ny - if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - write(logmsg,*) scalar_field_idx_grid_ny - call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) + read(value, *, iostat=iostat) scalar_field_idx_grid_ny + if (iostat /= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ScalarFieldIdxGridNY not an integer: "//trim(value), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + write(logmsg,*) scalar_field_idx_grid_ny + call ESMF_LogWrite('MOM_cap:ScalarFieldIdxGridNY = '//trim(logmsg), ESMF_LOGMSG_INFO) endif use_coldstart = .true. @@ -367,10 +367,10 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) if(use_mommesh)then geomtype = ESMF_GEOMTYPE_MESH call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', isPresent=isPresent, isSet=isSet, rc=rc) - if (.not. isPresent .and. .not. isSet) then - call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) - call ESMF_Finalize(endflag=ESMF_END_ABORT) - endif + if (.not. isPresent .and. .not. isSet) then + call ESMF_LogWrite('geomtype set to mesh but mesh_ocn is not specified', ESMF_LOGMSG_INFO) + call ESMF_Finalize(endflag=ESMF_END_ABORT) + endif else geomtype = ESMF_GEOMTYPE_GRID endif @@ -470,17 +470,17 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif + if (localPeCount == 1) then + call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) nthrds + else + nthrds = localPeCount + endif else - nthrds = localPeCount + nthrds = localPeCount endif write(logmsg,*) nthrds call ESMF_LogWrite(trim(subname)//': nthreads = '//trim(logmsg), ESMF_LOGMSG_INFO) @@ -493,27 +493,27 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! determine the calendar if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) calendar - select case (trim(calendar)) - case ("NO_LEAP") - call set_calendar_type (NOLEAP) - case ("GREGORIAN") - call set_calendar_type (GREGORIAN) - case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - end select - else - call set_calendar_type (NOLEAP) - endif + call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) calendar + select case (trim(calendar)) + case ("NO_LEAP") + call set_calendar_type (NOLEAP) + case ("GREGORIAN") + call set_calendar_type (GREGORIAN) + case default + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": Calendar not supported in MOM6: "//trim(calendar), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + end select + else + call set_calendar_type (NOLEAP) + endif else - call set_calendar_type (JULIAN) + call set_calendar_type (JULIAN) endif call diag_manager_init @@ -546,23 +546,23 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! reset shr logging to my log file if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - 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=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + 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=logunit,file=trim(diro)//"/"//trim(logfile)) + else + logunit = output_unit + endif else - logunit = output_unit + logunit = output_unit endif starttype = "" @@ -570,28 +570,28 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then - read(cvalue,*) starttype + read(cvalue,*) starttype else - call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & - ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:start_type unset - using input.nml for restart option', & + ESMF_LOGMSG_INFO) endif runtype = "" if (trim(starttype) == trim('startup')) then - runtype = "initial" + runtype = "initial" else if (trim(starttype) == trim('continue') ) then - runtype = "continue" + runtype = "continue" else if (trim(starttype) == trim('branch')) then - runtype = "continue" + runtype = "continue" else if (len_trim(starttype) > 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": unknown starttype - "//trim(starttype), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": unknown starttype - "//trim(starttype), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif if (len_trim(runtype) > 0) then - call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) + call ESMF_LogWrite('MOM_cap:startup = '//trim(runtype), ESMF_LOGMSG_INFO) endif restartfile = ""; restartfiles = "" @@ -606,46 +606,46 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) else if (runtype == "continue") then ! hybrid or branch or continuos runs - if (cesm_coupled) then - call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) - call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_VMGet(vm, localPet=localPet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (cesm_coupled) then + call ESMF_LogWrite('MOM_cap: restart requested, using rpointer.ocn', ESMF_LOGMSG_WARNING) + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (localPet == 0) then - ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', 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) - return + if (localPet == 0) then + ! this hard coded for rpointer.ocn right now + open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', 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) + return + endif + do + read(readunit,'(a)', iostat=iostat) restartfile + if (iostat /= 0) then + 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', & + line=__LINE__, file=u_FILE_u, rcToReturn=rc) + return endif - do - read(readunit,'(a)', iostat=iostat) restartfile - if (iostat /= 0) then - 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', & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) - return - endif - endif - ! check if the length of restartfiles variable is sufficient: - if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then - call MOM_error(FATAL, "Restart file name(s) too long.") - endif - restartfiles = trim(restartfiles) // " " // trim(restartfile) - enddo - close(readunit) - endif - ! broadcast attribute set on master task to all tasks - call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) - endif + endif + ! check if the length of restartfiles variable is sufficient: + if (len(restartfiles)-len(trim(restartfiles)) < len(trim(restartfile))) then + call MOM_error(FATAL, "Restart file name(s) too long.") + endif + restartfiles = trim(restartfiles) // " " // trim(restartfile) + enddo + close(readunit) + endif + ! broadcast attribute set on master task to all tasks + call ESMF_VMBroadcast(vm, restartfiles, count=len(restartfiles), rootPet=0, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite('MOM_cap: restart requested, use input.nml', ESMF_LOGMSG_WARNING) + endif endif @@ -733,9 +733,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (len_trim(scalar_field_name) > 0) then - call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") - end if + call fld_list_add(fldsToOcn_num, fldsToOcn, trim(scalar_field_name), "will_provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") + endif !--------- import fields ------------- @@ -917,17 +917,17 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_VMGet(vm, pet=localPet, peCount=localPeCount, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - if(localPeCount == 1) then - call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) nthrds - else - nthrds = localPeCount - endif + if (localPeCount == 1) then + call NUOPC_CompAttributeGet(gcomp, name="nthreads", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) nthrds + else + nthrds = localPeCount + endif else - nthrds = localPeCount + nthrds = localPeCount endif !$ call omp_set_num_threads(nthrds) @@ -949,7 +949,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_FAILURE call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif - ntiles=mpp_get_domain_npes(ocean_public%domain) + ntiles = mpp_get_domain_npes(ocean_public%domain) write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) @@ -961,414 +961,414 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) call mpp_get_pelist(ocean_public%domain, pe) if (dbug > 1) then - do n = 1,ntiles - write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - enddo + do n = 1,ntiles + write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + enddo endif !--------------------------------- ! Create either a grid or a mesh !--------------------------------- - !Get the ocean grid and sizes of global and computational domains - call get_ocean_grid(ocean_state, ocean_grid) + !Get the ocean grid and sizes of global and computational domains + call get_ocean_grid(ocean_state, ocean_grid) if (geomtype == ESMF_GEOMTYPE_MESH) then - !--------------------------------- - ! Create a MOM6 mesh - !--------------------------------- - - call get_global_grid_size(ocean_grid, ni, nj) - lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) - - ! Create the global index space for the computational domain - allocate(gindex(lsize)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - jg = j + ocean_grid%jdg_offset - do i = ocean_grid%isc, ocean_grid%iec - ig = i + ocean_grid%idg_offset - k = k + 1 ! Increment position within gindex - gindex(k) = ni * (jg - 1) + ig - enddo - enddo - - DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! read in the mesh - call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) - endif - - ! recreate the mesh using the above distGrid - EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Check for consistency of lat, lon and mask between mesh and mom6 grid - call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - allocate(ownedElemCoords(spatialDim*numOwnedElements)) - allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) - allocate(latMesh(numOwnedElements), lat(numOwnedElements)) - allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) - - call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - do n = 1,numOwnedElements - lonMesh(n) = ownedElemCoords(2*n-1) - latMesh(n) = ownedElemCoords(2*n) - end do - - elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - mask(n) = ocean_grid%mask2dT(ig,jg) - lon(n) = ocean_grid%geolonT(ig,jg) - lat(n) = ocean_grid%geolatT(ig,jg) - end do - end do - - eps_omesh = get_eps_omesh(ocean_state) - do n = 1,numOwnedElements - diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) - if (diff_lon > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& - "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh - call MOM_error(FATAL, err_msg) - end if - diff_lat = abs(latMesh(n) - lat(n)) - if (diff_lat > eps_omesh) then - frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& - "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& - "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" - write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh - call MOM_error(FATAL, err_msg) - end if - if (abs(maskMesh(n) - mask(n)) > 0) then - frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& - "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" - write(err_msg, frmt)n,maskMesh(n),mask(n) - call MOM_error(FATAL, err_msg) - end if - end do + !--------------------------------- + ! Create a MOM6 mesh + !--------------------------------- + + call get_global_grid_size(ocean_grid, ni, nj) + lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) + + ! Create the global index space for the computational domain + allocate(gindex(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex(k) = ni * (jg - 1) + ig + enddo + enddo - ! realize the import and export fields using the mesh - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! read in the mesh + call NUOPC_CompAttributeGet(gcomp, name='mesh_ocn', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + EMeshTemp = ESMF_MeshCreate(filename=trim(cvalue), fileformat=ESMF_FILEFORMAT_ESMFMESH, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then + write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) + endif - !--------------------------------- - ! determine flux area correction factors - module variables in mom_cap_methods - !--------------------------------- - ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for - ! grids that are calculated internally + ! recreate the mesh using the above distGrid + EMesh = ESMF_MeshCreate(EMeshTemp, elementDistgrid=Distgrid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! Determine mesh areas for regridding - call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! Check for consistency of lat, lon and mask between mesh and mom6 grid + call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - allocate (mod2med_areacor(numOwnedElements)) - allocate (med2mod_areacor(numOwnedElements)) - mod2med_areacor(:) = 1._ESMF_KIND_R8 - med2mod_areacor(:) = 1._ESMF_KIND_R8 + allocate(ownedElemCoords(spatialDim*numOwnedElements)) + allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) + allocate(latMesh(numOwnedElements), lat(numOwnedElements)) + allocate(maskMesh(numOwnedElements), mask(numOwnedElements)) + + call ESMF_MeshGet(Emesh, ownedElemCoords=ownedElemCoords, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + do n = 1,numOwnedElements + lonMesh(n) = ownedElemCoords(2*n-1) + latMesh(n) = ownedElemCoords(2*n) + end do + + elemMaskArray = ESMF_ArrayCreate(Distgrid, maskMesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + mask(n) = ocean_grid%mask2dT(ig,jg) + lon(n) = ocean_grid%geolonT(ig,jg) + lat(n) = ocean_grid%geolatT(ig,jg) + end do + end do + + eps_omesh = get_eps_omesh(ocean_state) + do n = 1,numOwnedElements + diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) + if (diff_lon > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& + "greater than parameter EPS_OMESH. n, lonMesh(n), lon(n), diff_lon, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,lonMesh(n),lon(n), diff_lon, eps_omesh + call MOM_error(FATAL, err_msg) + end if + diff_lat = abs(latMesh(n) - lat(n)) + if (diff_lat > eps_omesh) then + frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is"//& + "greater than parameter EPS_OMESH. n, latMesh(n), lat(n), diff_lat, "//& + "EPS_OMESH= ',i8,2(f21.13,3x),2(d21.5))" + write(err_msg, frmt)n,latMesh(n),lat(n), diff_lat, eps_omesh + call MOM_error(FATAL, err_msg) + end if + if (abs(maskMesh(n) - mask(n)) > 0) then + frmt = "('ERROR: ESMF mesh and MOM6 domain masks are inconsistent! - "//& + "MOM n, maskMesh(n), mask(n) = ',3(i8,2x))" + write(err_msg, frmt)n,maskMesh(n),mask(n) + call MOM_error(FATAL, err_msg) + end if + end do + + ! realize the import and export fields using the mesh + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", mesh=Emesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + !--------------------------------- + ! determine flux area correction factors - module variables in mom_cap_methods + !--------------------------------- + ! Area correction factors are ONLY valid for meshes that are read in - so do not need them for + ! grids that are calculated internally + + ! Determine mesh areas for regridding + call ESMF_MeshGet(Emesh, numOwnedElements=numOwnedElements, spatialDim=spatialDim, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate (mod2med_areacor(numOwnedElements)) + allocate (med2mod_areacor(numOwnedElements)) + mod2med_areacor(:) = 1._ESMF_KIND_R8 + med2mod_areacor(:) = 1._ESMF_KIND_R8 #ifdef CESMCOUPLED - ! Determine model areas and flux correction factors (module variables in mom_) - call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldRegridGetArea(lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - allocate(mesh_areas(numOwnedElements)) - allocate(model_areas(numOwnedElements)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - do i = ocean_grid%isc, ocean_grid%iec - k = k + 1 ! Increment position within gindex - if (mask(k) /= 0) then - mesh_areas(k) = dataPtr_mesh_areas(k) - model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 - mod2med_areacor(k) = model_areas(k) / mesh_areas(k) - med2mod_areacor(k) = mesh_areas(k) / model_areas(k) - end if - end do - end do - deallocate(mesh_areas) - deallocate(model_areas) - - ! Write diagnostic output for correction factors - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) - if (localPet == 0) then - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' - end if + ! Determine model areas and flux correction factors (module variables in mom_) + call ESMF_StateGet(exportState, itemName=trim(fldsFrOcn(2)%stdname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldRegridGetArea(lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(lfield, farrayPtr=dataPtr_mesh_areas, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(mesh_areas(numOwnedElements)) + allocate(model_areas(numOwnedElements)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + do i = ocean_grid%isc, ocean_grid%iec + k = k + 1 ! Increment position within gindex + if (mask(k) /= 0) then + mesh_areas(k) = dataPtr_mesh_areas(k) + model_areas(k) = ocean_grid%AreaT(i,j) / ocean_grid%Rad_Earth_L**2 + mod2med_areacor(k) = model_areas(k) / mesh_areas(k) + med2mod_areacor(k) = mesh_areas(k) / model_areas(k) + end if + end do + end do + deallocate(mesh_areas) + deallocate(model_areas) + + ! Write diagnostic output for correction factors + min_mod2med_areacor = minval(mod2med_areacor) + max_mod2med_areacor = maxval(mod2med_areacor) + min_med2mod_areacor = minval(med2mod_areacor) + max_med2mod_areacor = maxval(med2mod_areacor) + call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) + call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) + call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) + call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) + if (localPet == 0) then + write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' + write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' + end if #endif - deallocate(ownedElemCoords) - deallocate(lonMesh , lon ) - deallocate(latMesh , lat ) - deallocate(maskMesh, mask) + deallocate(ownedElemCoords) + deallocate(lonMesh , lon ) + deallocate(latMesh , lat ) + deallocate(maskMesh, mask) else if (geomtype == ESMF_GEOMTYPE_GRID) then - !--------------------------------- - ! create a MOM6 grid - !--------------------------------- - - ! generate delayout and dist_grid - - allocate(deBlockList(2,2,ntiles)) - allocate(petMap(ntiles)) - allocate(deLabelList(ntiles)) - - do n = 1, ntiles - deLabelList(n) = n - deBlockList(1,1,n) = xb(n) - deBlockList(1,2,n) = xe(n) - deBlockList(2,1,n) = yb(n) - deBlockList(2,2,n) = ye(n) - petMap(n) = pe(n) - ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) - ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side - enddo - - delayout = ESMF_DELayoutCreate(petMap, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! rsd this assumes tripole grid, but sometimes in CESM a bipole - ! grid is used -- need to introduce conditional logic here - - allocate(connectionList(2)) - - ! bipolar boundary condition at top row: nyg - call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & - orientationVector=(/-1, -2/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! periodic boundary condition along first dimension - call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & - tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & - ! indexflag = ESMF_INDEX_DELOCAL, & - deBlockList=deBlockList, & - ! deLabelList=deLabelList, & - delayout=delayout, & - connectionList=connectionList, & - rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - deallocate(xb,xe,yb,ye,pe) - deallocate(connectionList) - deallocate(deLabelList) - deallocate(deBlockList) - deallocate(petMap) - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - allocate(indexList(cnt)) - write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& - indexList(1),indexList(cnt),minval(indexList), maxval(indexList) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - deallocate(IndexList) - - ! create grid - - gridIn = ESMF_GridCreate(distgrid=distgrid, & - gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & - coordSys = ESMF_COORDSYS_SPH_DEG, & - rc = rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! Attach area to the Grid optionally. By default the cell areas are computed. - if(grid_attach_area) then - call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & - staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_xcen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_ycen, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=1, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_xcor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetCoord(gridIn, coordDim=2, & - staggerloc=ESMF_STAGGERLOC_CORNER, & - farrayPtr=dataPtr_ycor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_mask, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if(grid_attach_area) then - call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & - staggerloc=ESMF_STAGGERLOC_CENTER, & - farrayPtr=dataPtr_area, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif - - ! load up area, mask, center and corner values - ! area, mask, and centers should be same size in mom and esmf grid - ! corner points may not be, need to offset corner points by 1 in i and j - ! retrieve these values directly from ocean_grid, which contains halo - ! values for j=0 and wrap-around in i. on tripole seam, decomposition - ! domains are 1 larger in j; to load corner values need to loop one extra row - - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) - - lbnd1 = lbound(dataPtr_mask,1) - ubnd1 = ubound(dataPtr_mask,1) - lbnd2 = lbound(dataPtr_mask,2) - ubnd2 = ubound(dataPtr_mask,2) - - lbnd3 = lbound(dataPtr_xcor,1) - ubnd3 = ubound(dataPtr_xcor,1) - lbnd4 = lbound(dataPtr_xcor,2) - ubnd4 = ubound(dataPtr_xcor,2) - - write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=SUBNAME//": fld and grid do not have the same size.", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) - dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) - dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) - if(grid_attach_area) then - dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) - endif - enddo - enddo - - jlast = jec - if(jec == nyg)jlast = jec+1 - - do j = jsc, jlast - j1 = j + lbnd4 - jsc - jg = j + ocean_grid%jsc - jsc - 1 - do i = isc, iec - i1 = i + lbnd3 - isc - ig = i + ocean_grid%isc - isc - 1 - dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) - dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) - enddo - enddo - - write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - if(grid_attach_area) then - write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - endif - - write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) - call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) - - gridOut = gridIn ! for now out same as in - - call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + !--------------------------------- + ! create a MOM6 grid + !--------------------------------- + + ! generate delayout and dist_grid + + allocate(deBlockList(2,2,ntiles)) + allocate(petMap(ntiles)) + allocate(deLabelList(ntiles)) + + do n = 1, ntiles + deLabelList(n) = n + deBlockList(1,1,n) = xb(n) + deBlockList(1,2,n) = xe(n) + deBlockList(2,1,n) = yb(n) + deBlockList(2,2,n) = ye(n) + petMap(n) = pe(n) + ! write(tmpstr,'(a,3i8)') subname//' iglo = ',n,deBlockList(1,1,n),deBlockList(1,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,3i8)') subname//' jglo = ',n,deBlockList(2,1,n),deBlockList(2,2,n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + ! write(tmpstr,'(a,2i8)') subname//' pe = ',n,petMap(n) + ! call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + !--- assume a tile with starting index of 1 has an equivalent wraparound tile on the other side + enddo + + delayout = ESMF_DELayoutCreate(petMap, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! rsd this assumes tripole grid, but sometimes in CESM a bipole + ! grid is used -- need to introduce conditional logic here + + allocate(connectionList(2)) + + ! bipolar boundary condition at top row: nyg + call ESMF_DistGridConnectionSet(connectionList(1), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg+1, 2*nyg+1/), & + orientationVector=(/-1, -2/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! periodic boundary condition along first dimension + call ESMF_DistGridConnectionSet(connectionList(2), tileIndexA=1, & + tileIndexB=1, positionVector=(/nxg, 0/), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + distgrid = ESMF_DistGridCreate(minIndex=(/1,1/), maxIndex=(/nxg,nyg/), & + ! indexflag = ESMF_INDEX_DELOCAL, & + deBlockList=deBlockList, & + ! deLabelList=deLabelList, & + delayout=delayout, & + connectionList=connectionList, & + rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + deallocate(xb,xe,yb,ye,pe) + deallocate(connectionList) + deallocate(deLabelList) + deallocate(deBlockList) + deallocate(petMap) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, elementCount=cnt, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + allocate(indexList(cnt)) + write(tmpstr,'(a,i8)') subname//' distgrid cnt= ',cnt + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + call ESMF_DistGridGet(distgrid=distgrid, localDE=0, seqIndexList=indexList, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + write(tmpstr,'(a,4i8)') subname//' distgrid list= ',& + indexList(1),indexList(cnt),minval(indexList), maxval(indexList) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + deallocate(IndexList) + + ! create grid + + gridIn = ESMF_GridCreate(distgrid=distgrid, & + gridEdgeLWidth=(/0,0/), gridEdgeUWidth=(/0,1/), & + coordSys = ESMF_COORDSYS_SPH_DEG, & + rc = rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddCoord(gridIn, staggerLoc=ESMF_STAGGERLOC_CORNER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_MASK, itemTypeKind=ESMF_TYPEKIND_I4, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! Attach area to the Grid optionally. By default the cell areas are computed. + if (grid_attach_area) then + call ESMF_GridAddItem(gridIn, itemFlag=ESMF_GRIDITEM_AREA, itemTypeKind=ESMF_TYPEKIND_R8, & + staggerLoc=ESMF_STAGGERLOC_CENTER, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_xcen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_ycen, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=1, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_xcor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetCoord(gridIn, coordDim=2, & + staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=dataPtr_ycor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_MASK, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_mask, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (grid_attach_area) then + call ESMF_GridGetItem(gridIn, itemflag=ESMF_GRIDITEM_AREA, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=dataPtr_area, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + + ! load up area, mask, center and corner values + ! area, mask, and centers should be same size in mom and esmf grid + ! corner points may not be, need to offset corner points by 1 in i and j + ! retrieve these values directly from ocean_grid, which contains halo + ! values for j=0 and wrap-around in i. on tripole seam, decomposition + ! domains are 1 larger in j; to load corner values need to loop one extra row + + call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + + lbnd1 = lbound(dataPtr_mask,1) + ubnd1 = ubound(dataPtr_mask,1) + lbnd2 = lbound(dataPtr_mask,2) + ubnd2 = ubound(dataPtr_mask,2) + + lbnd3 = lbound(dataPtr_xcor,1) + ubnd3 = ubound(dataPtr_xcor,1) + lbnd4 = lbound(dataPtr_xcor,2) + ubnd4 = ubound(dataPtr_xcor,2) + + write(tmpstr,*) subname//' iscjsc = ',isc,iec,jsc,jec + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub12 = ',lbnd1,ubnd1,lbnd2,ubnd2 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' lbub34 = ',lbnd3,ubnd3,lbnd4,ubnd4 + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + if (iec-isc /= ubnd1-lbnd1 .or. jec-jsc /= ubnd2-lbnd2) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=SUBNAME//": fld and grid do not have the same size.", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr_mask(i1,j1) = ocean_grid%mask2dT(ig,jg) + dataPtr_xcen(i1,j1) = ocean_grid%geolonT(ig,jg) + dataPtr_ycen(i1,j1) = ocean_grid%geolatT(ig,jg) + if(grid_attach_area) then + dataPtr_area(i1,j1) = ocean_grid%US%L_to_m**2 * ocean_grid%areaT(ig,jg) + endif + enddo + enddo + + jlast = jec + if (jec == nyg)jlast = jec+1 + + do j = jsc, jlast + j1 = j + lbnd4 - jsc + jg = j + ocean_grid%jsc - jsc - 1 + do i = isc, iec + i1 = i + lbnd3 - isc + ig = i + ocean_grid%isc - isc - 1 + dataPtr_xcor(i1,j1) = ocean_grid%geolonBu(ig,jg) + dataPtr_ycor(i1,j1) = ocean_grid%geolatBu(ig,jg) + enddo + enddo + + write(tmpstr,*) subname//' mask = ',minval(dataPtr_mask),maxval(dataPtr_mask) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + if (grid_attach_area) then + write(tmpstr,*) subname//' area = ',minval(dataPtr_area),maxval(dataPtr_area) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + endif + + write(tmpstr,*) subname//' xcen = ',minval(dataPtr_xcen),maxval(dataPtr_xcen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycen = ',minval(dataPtr_ycen),maxval(dataPtr_ycen) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' xcor = ',minval(dataPtr_xcor),maxval(dataPtr_xcor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + write(tmpstr,*) subname//' ycor = ',minval(dataPtr_ycor),maxval(dataPtr_ycor) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) + + gridOut = gridIn ! for now out same as in + + call MOM_RealizeFields(importState, fldsToOcn_num, fldsToOcn, "Ocn import", grid=gridIn, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call MOM_RealizeFields(exportState, fldsFrOcn_num, fldsFrOcn, "Ocn export", grid=gridOut, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1376,13 +1376,13 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) !--------------------------------- if (len_trim(scalar_field_name) > 0) then - call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & + call State_SetScalar(real(nxg,ESMF_KIND_R8),scalar_field_idx_grid_nx, exportState, localPet, & scalar_field_name, scalar_field_count, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & - scalar_field_name, scalar_field_count, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetScalar(real(nyg,ESMF_KIND_R8),scalar_field_idx_grid_ny, exportState, localPet, & + scalar_field_name, scalar_field_count, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !--------------------------------- @@ -1471,8 +1471,8 @@ subroutine DataInitialize(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - if(write_diagnostics) then - do n = 1,fldsFrOcn_num + if (write_diagnostics) then + do n = 1,fldsFrOcn_num fldname = fldsFrOcn(n)%shortname call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1485,7 +1485,7 @@ subroutine DataInitialize(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif end subroutine DataInitialize @@ -1589,117 +1589,117 @@ subroutine ModelAdvance(gcomp, rc) endif if (do_advance) then - ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps - if (currTime == startTime + timeStep) then - call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) - Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime - - call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) - Time_step_coupled = 2 * esmf2fms_time(timeStep) - endif - end if + ! If the second cpl tstep of a startup run, step back a cpl tstep and advance for two cpl tsteps + if (currTime == startTime + timeStep) then + call ESMF_LogWrite("MOM6 - Stepping back one coupling timestep", ESMF_LOGMSG_INFO) + Time = esmf2fms_time(currTime-timeStep) ! i.e., startTime + + call ESMF_LogWrite("MOM6 - doubling the coupling timestep", ESMF_LOGMSG_INFO) + Time_step_coupled = 2 * esmf2fms_time(timeStep) + endif + endif endif endif if (do_advance) then - call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr - ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr - ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr + Ice_ocean_boundary => ocean_internalstate%ptr%ice_ocean_boundary_type_ptr + ocean_public => ocean_internalstate%ptr%ocean_public_type_ptr + ocean_state => ocean_internalstate%ptr%ocean_state_type_ptr - !--------------- - ! Write diagnostics for import - !--------------- + !--------------- + ! Write diagnostics for import + !--------------- - if (write_diagnostics) then + if (write_diagnostics) then do n = 1,fldsToOcn_num - fldname = fldsToOcn(n)%shortname - call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldname = fldsToOcn(n)%shortname + call ESMF_StateGet(importState, itemName=trim(fldname), itemType=itemType, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (itemType /= ESMF_STATEITEM_NOTFOUND) then - call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (itemType /= ESMF_STATEITEM_NOTFOUND) then + call ESMF_StateGet(importState, itemName=trim(fldname), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & - timeslice=1, overwrite=overwrite_timeslice, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + call ESMF_FieldWrite(lfield, fileName='field_ocn_import_'//trim(import_timestr)//'.nc', & + timeslice=1, overwrite=overwrite_timeslice, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif enddo - endif + endif - if (dbug > 0) then - call state_diagnose(importState,subname//':IS ',rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + if (dbug > 0) then + call state_diagnose(importState,subname//':IS ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !--------------- - ! Get ocean grid - !--------------- + !--------------- + ! Get ocean grid + !--------------- - call get_ocean_grid(ocean_state, ocean_grid) + call get_ocean_grid(ocean_state, ocean_grid) - !--------------- - ! Import data - !--------------- + !--------------- + ! Import data + !--------------- - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - !--------------- - ! Update MOM6 - !--------------- + !--------------- + ! Update MOM6 + !--------------- - if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") - call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) - if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") + if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM update_ocean_model: ") + call update_ocean_model(Ice_ocean_boundary, ocean_state, ocean_public, Time, Time_step_coupled) + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM update_ocean_model: ") - !--------------- - ! Export Data - !--------------- + !--------------- + ! Export Data + !--------------- - call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (dbug > 0) then - call state_diagnose(exportState,subname//':ES ',rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - end if + if (dbug > 0) then + call state_diagnose(exportState,subname//':ES ',rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if endif !--------------- ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- ! If restart alarm exists and is ringing - write restart file !--------------- if (restart_mode == 'alarms') then - call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then - if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! turn off the alarm - call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! turn off the alarm + call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! determine restart filename - call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! determine restart filename + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeGet (MyTime, yy=year, mm=month, dd=day, h=hour, m=minute, s=seconds, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (cesm_coupled) then + if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name='case_name', value=casename, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) @@ -1714,36 +1714,36 @@ 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) - 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) - return - endif - write(writeunit,'(a)') trim(restartname)//'.nc' - - if (num_rest_files > 1) then - ! append i.th restart file name to rpointer - do i=1, num_rest_files-1 - if (i < 10) then - write(suffix,'("_",I1)') i - else - write(suffix,'("_",I2)') i - endif - write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' - enddo - endif - close(writeunit) + open(newunit=writeunit, file='rpointer.ocn', 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) + return + endif + write(writeunit,'(a)') trim(restartname)//'.nc' + + if (num_rest_files > 1) then + ! append i.th restart file name to rpointer + do i=1, num_rest_files-1 + if (i < 10) then + write(suffix,'("_",I1)') i + else + write(suffix,'("_",I2)') i + endif + write(writeunit,'(a)') trim(restartname) // trim(suffix) // '.nc' + enddo + endif + close(writeunit) endif - else ! not cesm_coupled + else ! not cesm_coupled ! write the final restart without a timestamp if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then - write(restartname,'(A)')"MOM.res" - write(stoch_restartname,'(A)')"ocn_stoch.res.nc" + write(restartname,'(A)')"MOM.res" + write(stoch_restartname,'(A)')"ocn_stoch.res.nc" else - write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & + write(restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2)') & "MOM.res.", year, month, day, hour, minute, seconds - write(stoch_restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & + write(stoch_restartname,'(A,I4.4,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,"-",I2.2,A)') & "ocn_stoch.res.", year, month, day, hour, minute, seconds,".nc" endif call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) @@ -1752,20 +1752,20 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname, & stoch_restartname=stoch_restartname) - endif + endif - if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) - endif - endif - end if ! restart_mode + if (is_root_pe()) then + write(logunit,*) subname//' writing restart file ',trim(restartname) + endif + endif + endif ! restart_mode !--------------- ! Write diagnostics !--------------- if (write_diagnostics) then - do n = 1,fldsFrOcn_num + do n = 1,fldsFrOcn_num fldname = fldsFrOcn(n)%shortname call ESMF_StateGet(exportState, itemName=trim(fldname), itemType=itemType, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1778,7 +1778,7 @@ subroutine ModelAdvance(gcomp, rc) timeslice=1, overwrite=overwrite_timeslice, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif - enddo + enddo endif if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") @@ -1848,103 +1848,103 @@ subroutine ModelSetRunClock(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (first_time) then - !-------------------------------- - ! set restart alarm - !-------------------------------- + !-------------------------------- + ! set restart alarm + !-------------------------------- - ! defaults - restart_n = 0 - restart_ymd = 0 + ! defaults + restart_n = 0 + restart_ymd = 0 - if (cesm_coupled) then + if (cesm_coupled) then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=restart_option, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! If restart_option is set then must also have set either restart_n or restart_ymd - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_n - endif - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_ymd - endif - if (restart_n == 0 .and. restart_ymd == 0) then - call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & - msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) + ! If restart_option is set then must also have set either restart_n or restart_ymd + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_n + endif + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + endif + if (restart_n == 0 .and. restart_ymd == 0) then + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_ymd are zero for restart_option set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_LogWrite(subname//" Set restart option = "//restart_option, ESMF_LOGMSG_INFO) - else - call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call NUOPC_CompAttributeGet(gcomp, name="restart_n", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! If restart_n is set and non-zero, then restart_option must be available from config - if (isPresent .and. isSet) then - call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) - read(cvalue,*) restart_n - if(restart_n /= 0)then - call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_option - call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & - ESMF_LOGMSG_INFO) - else - call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & - msg=subname//": ERROR both restart_n and restart_option must be set ", & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return - endif - ! not used in nems - call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & - isPresent=isPresent, isSet=isSet, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresent .and. isSet) then - read(cvalue,*) restart_ymd - call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) - endif + ! If restart_n is set and non-zero, then restart_option must be available from config + if (isPresent .and. isSet) then + call ESMF_LogWrite(subname//" Restart_n = "//trim(cvalue), ESMF_LOGMSG_INFO) + read(cvalue,*) restart_n + if (restart_n /= 0)then + call NUOPC_CompAttributeGet(gcomp, name="restart_option", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_option + call ESMF_LogWrite(subname//" Restart_option = "//restart_option, & + ESMF_LOGMSG_INFO) else - ! restart_n is zero, restarts will be written at finalize only (no alarm control) - restart_mode = 'no_alarms' - call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) + call ESMF_LogSetError(ESMF_RC_VAL_WRONG, & + msg=subname//": ERROR both restart_n and restart_option must be set ", & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif + ! not used in nems + call NUOPC_CompAttributeGet(gcomp, name="restart_ymd", value=cvalue, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + read(cvalue,*) restart_ymd + call ESMF_LogWrite(subname//" Restart_ymd = "//trim(cvalue), ESMF_LOGMSG_INFO) + endif + else + ! restart_n is zero, restarts will be written at finalize only (no alarm control) + restart_mode = 'no_alarms' + call ESMF_LogWrite(subname//" Restarts will be written at finalize only", ESMF_LOGMSG_INFO) endif - endif - - if (restart_mode == 'alarms') then - call AlarmInit(mclock, & - alarm = restart_alarm, & - option = trim(restart_option), & - opt_n = restart_n, & - opt_ymd = restart_ymd, & - RefTime = mcurrTime, & - alarmname = 'restart_alarm', rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif + endif - call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) - end if + if (restart_mode == 'alarms') then + call AlarmInit(mclock, & + alarm = restart_alarm, & + option = trim(restart_option), & + opt_n = restart_n, & + opt_ymd = restart_ymd, & + RefTime = mcurrTime, & + alarmname = 'restart_alarm', rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call ESMF_AlarmSet(restart_alarm, clock=mclock, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_LogWrite(subname//" Restart alarm is Created and Set", ESMF_LOGMSG_INFO) + end if - ! create a 1-shot alarm at the driver stop time - stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) - call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + ! create a 1-shot alarm at the driver stop time + stop_alarm = ESMF_AlarmCreate(mclock, ringtime=dstopTime, name = "stop_alarm", rc=rc) + call ESMF_LogWrite(subname//" Create Stop alarm", ESMF_LOGMSG_INFO) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) - call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) + call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) + call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) - first_time = .false. + first_time = .false. endif @@ -2002,9 +2002,9 @@ subroutine ocean_model_finalize(gcomp, rc) ! Do not write a restart unless mode is no_alarms if (restart_mode == 'no_alarms') then - write_restart = .true. + write_restart = .true. else - write_restart = .false. + write_restart = .false. end if if (write_restart)call ESMF_LogWrite("No Restart Alarm, writing restart at Finalize ", & ESMF_LOGMSG_INFO) @@ -2046,9 +2046,9 @@ subroutine State_SetScalar(value, scalar_id, State, mytask, scalar_name, scalar_ if (ChkErr(rc,__LINE__,u_FILE_u)) return if (scalar_id < 0 .or. scalar_id > scalar_count) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//": ERROR in scalar_id", line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif farrayptr(scalar_id,1) = value @@ -2085,7 +2085,7 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) if (field_defs(i)%shortname == scalar_field_name) then call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected on root pe.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO) call SetScalarField(field, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -2093,29 +2093,29 @@ subroutine MOM_RealizeFields(state, nfields, field_defs, tag, grid, mesh, rc) else call ESMF_LogWrite(subname // tag // " Field "// trim(field_defs(i)%stdname) // " is connected.", & - ESMF_LOGMSG_INFO) + ESMF_LOGMSG_INFO) if (present(grid)) then - field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & - name=field_defs(i)%shortname, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + field = ESMF_FieldCreate(grid, ESMF_TYPEKIND_R8, indexflag=ESMF_INDEX_DELOCAL, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr2d(:,:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr2d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr2d(:,:) = 0.0 else if (present(mesh)) then - field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & - name=field_defs(i)%shortname, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + field = ESMF_FieldCreate(mesh=mesh, typekind=ESMF_TYPEKIND_R8, meshloc=ESMF_MESHLOC_ELEMENT, & + name=field_defs(i)%shortname, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - ! initialize fldptr to zero - call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - fldptr1d(:) = 0.0 + ! initialize fldptr to zero + call ESMF_FieldGet(field, farrayPtr=fldptr1d, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + fldptr1d(:) = 0.0 endif @@ -2186,17 +2186,17 @@ subroutine fld_list_add(num, fldlist, stdname, transferOffer, shortname) ! fill in the new entry num = num + 1 if (num > fldsMax) then - call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & - msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & - line=__LINE__, file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_VAL_OUTOFRANGE, & + msg=trim(subname)//": ERROR number of field exceeded fldsMax: "//trim(stdname), & + line=__LINE__, file=__FILE__, rcToReturn=rc) + return endif fldlist(num)%stdname = trim(stdname) if (present(shortname)) then - fldlist(num)%shortname = trim(shortname) + fldlist(num)%shortname = trim(shortname) else - fldlist(num)%shortname = trim(stdname) + fldlist(num)%shortname = trim(stdname) endif fldlist(num)%transferOffer = trim(transferOffer) diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index bb9743bb84..a0b6b525d4 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -37,8 +37,8 @@ module MOM_cap_methods !> Get field pointer interface State_GetFldPtr - module procedure State_GetFldPtr_1d - module procedure State_GetFldPtr_2d + module procedure State_GetFldPtr_1d + module procedure State_GetFldPtr_2d end interface integer :: import_cnt = 0!< used to skip using the import state @@ -151,14 +151,14 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! rotate taux and tauy from true zonal/meridional to local coordinates do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & - - ocean_grid%sin_rot(ig,jg)*tauy(i,j) - ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & - + ocean_grid%sin_rot(ig,jg)*taux(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%u_flux(i,j) = ocean_grid%cos_rot(ig,jg)*taux(i,j) & + - ocean_grid%sin_rot(ig,jg)*tauy(i,j) + ice_ocean_boundary%v_flux(i,j) = ocean_grid%cos_rot(ig,jg)*tauy(i,j) & + + ocean_grid%sin_rot(ig,jg)*taux(i,j) + enddo enddo deallocate(taux, tauy) @@ -275,11 +275,11 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! Langmuir enhancement factor !---- if ( associated(ice_ocean_boundary%lamult) ) then - ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Sw_lamult', & - isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - endif + ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 + call state_getimport(importState, 'Sw_lamult', & + isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + endif !---- ! Partitioned Stokes Drift Components @@ -307,24 +307,24 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! rotate from true zonal/meridional to local coordinates do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ice_ocean_boundary%ustkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stkx1(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky1(i,j) - ice_ocean_boundary%vstkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stky1(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx1(i,j) - - ice_ocean_boundary%ustkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stkx2(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky2(i,j) - ice_ocean_boundary%vstkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stky2(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx2(i,j) - - ice_ocean_boundary%ustkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stkx3(i,j) & - - ocean_grid%sin_rot(ig,jg)*stky3(i,j) - ice_ocean_boundary%vstkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stky3(i,j) & - + ocean_grid%sin_rot(ig,jg)*stkx3(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ice_ocean_boundary%ustkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stkx1(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky1(i,j) + ice_ocean_boundary%vstkb(i,j,1) = ocean_grid%cos_rot(ig,jg)*stky1(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx1(i,j) + + ice_ocean_boundary%ustkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stkx2(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky2(i,j) + ice_ocean_boundary%vstkb(i,j,2) = ocean_grid%cos_rot(ig,jg)*stky2(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx2(i,j) + + ice_ocean_boundary%ustkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stkx3(i,j) & + - ocean_grid%sin_rot(ig,jg)*stky3(i,j) + ice_ocean_boundary%vstkb(i,j,3) = ocean_grid%cos_rot(ig,jg)*stky3(i,j) & + + ocean_grid%sin_rot(ig,jg)*stkx3(i,j) + enddo enddo deallocate(stkx1,stkx2,stkx3,stky1,stky2,stky3) @@ -374,9 +374,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Use Adcroft's rule of reciprocals; it does the right thing here. if (real(dt_int) > 0.0) then - inv_dt_int = 1.0 / real(dt_int) + inv_dt_int = 1.0 / real(dt_int) else - inv_dt_int = 0.0 + inv_dt_int = 0.0 endif !---------------- @@ -391,11 +391,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(omask(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + omask(i,j) = nint(ocean_grid%mask2dT(ig,jg)) + enddo enddo call State_SetExport(exportState, 'ocean_mask', & @@ -431,14 +431,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(ocm_rot(isc:iec, jsc:jec)) do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - ocz(i,j) = ocean_public%u_surf(i,j) - ocm(i,j) = ocean_public%v_surf(i,j) - ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) - ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + ocz(i,j) = ocean_public%u_surf(i,j) + ocm(i,j) = ocean_public%v_surf(i,j) + ocz_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocz(i,j) + ocean_grid%sin_rot(ig,jg)*ocm(i,j) + ocm_rot(i,j) = ocean_grid%cos_rot(ig,jg)*ocm(i,j) - ocean_grid%sin_rot(ig,jg)*ocz(i,j) + enddo enddo call State_SetExport(exportState, 'ocn_current_zonal', & @@ -456,9 +456,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'So_bldepth', & - isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'So_bldepth', & + isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif ! ------- @@ -470,14 +470,14 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, allocate(melt_potential(isc:iec, jsc:jec)) do j = jsc,jec - do i = isc,iec - if (ocean_public%frazil(i,j) > 0.0) then - melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int - else - melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int - if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 - endif - enddo + do i = isc,iec + if (ocean_public%frazil(i,j) > 0.0) then + melt_potential(i,j) = ocean_public%frazil(i,j) * inv_dt_int + else + melt_potential(i,j) = -ocean_public%melt_potential(i,j) * inv_dt_int + if (melt_potential(i,j) > 0.0) melt_potential(i,j) = 0.0 + endif + enddo enddo call State_SetExport(exportState, 'freezing_melting_potential', & @@ -491,9 +491,9 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'sea_level', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'sea_level', & - isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call State_SetExport(exportState, 'sea_level', & + isc, iec, jsc, jec, ocean_public%sea_lev, ocean_grid, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !---------------- @@ -512,11 +512,11 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! Make a copy of ssh in order to do a halo update (ssh has local indexing with halos) do j = ocean_grid%jsc, ocean_grid%jec - jloc = j + ocean_grid%jdg_offset - do i = ocean_grid%isc,ocean_grid%iec - iloc = i + ocean_grid%idg_offset - ssh(i,j) = ocean_public%sea_lev(iloc,jloc) - enddo + jloc = j + ocean_grid%jdg_offset + do i = ocean_grid%isc,ocean_grid%iec + iloc = i + ocean_grid%idg_offset + ssh(i,j) = ocean_public%sea_lev(iloc,jloc) + enddo enddo ! Update halo of ssh so we can calculate gradients (local indexing) @@ -559,7 +559,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, do jglob = jsc, jec j = jglob + ocean_grid%jsc - jsc do iglob = isc,iec - i = iglob + ocean_grid%isc - isc + i = iglob + ocean_grid%isc - isc ! This is a PLM slope which might be less prone to the A-ocean_grid null mode slp_L = ssh(i,J) - ssh(i,J-1) * ocean_grid%mask2dCv(i,j-1) if (ocean_grid%mask2dCv(i,j-1)==0.) slp_L = 0. @@ -586,12 +586,12 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! "ocean_grid" uses has halos and uses local indexing. do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) - dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) - enddo + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + dhdx_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdx(i,j) + ocean_grid%sin_rot(ig,jg)*dhdy(i,j) + dhdy_rot(i,j) = ocean_grid%cos_rot(ig,jg)*dhdy(i,j) - ocean_grid%sin_rot(ig,jg)*dhdx(i,j) + enddo enddo call State_SetExport(exportState, 'sea_surface_slope_zonal', & @@ -680,54 +680,54 @@ subroutine State_GetImport(state, fldname, isc, iec, jsc, jec, output, do_sum, a call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then - - ! get field pointer - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - ! determine output array and apply area correction if present - n = 0 - do j = jsc,jec - do i = isc,iec - n = n + 1 - if (present(do_sum)) then - if (present(areacor)) then - output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) - else - output(i,j) = output(i,j) + dataPtr1d(n) - end if - else - if (present(areacor)) then - output(i,j) = dataPtr1d(n) * areacor(n) - else - output(i,j) = dataPtr1d(n) - end if - endif - enddo + if (geomtype == ESMF_GEOMTYPE_MESH) then + + ! get field pointer + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! determine output array and apply area correction if present + n = 0 + do j = jsc,jec + do i = isc,iec + n = n + 1 + if (present(do_sum)) then + if (present(areacor)) then + output(i,j) = output(i,j) + dataPtr1d(n) * areacor(n) + else + output(i,j) = output(i,j) + dataPtr1d(n) + end if + else + if (present(areacor)) then + output(i,j) = dataPtr1d(n) * areacor(n) + else + output(i,j) = dataPtr1d(n) + end if + endif enddo + enddo - else if (geomtype == ESMF_GEOMTYPE_GRID) then + else if (geomtype == ESMF_GEOMTYPE_GRID) then - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) - do j = jsc, jec - j1 = j + lbnd2 - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - if (present(do_sum)) then - output(i,j) = output(i,j) + dataPtr2d(i1,j1) - else - output(i,j) = dataPtr2d(i1,j1) - endif - enddo + do j = jsc, jec + j1 = j + lbnd2 - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + if (present(do_sum)) then + output(i,j) = output(i,j) + dataPtr2d(i1,j1) + else + output(i,j) = dataPtr2d(i1,j1) + endif enddo + enddo - endif + endif endif @@ -769,45 +769,45 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid call ESMF_StateGet(State, trim(fldname), itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - if (geomtype == ESMF_GEOMTYPE_MESH) then + if (geomtype == ESMF_GEOMTYPE_MESH) then - call state_getfldptr(state, trim(fldname), dataptr1d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return + call state_getfldptr(state, trim(fldname), dataptr1d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return - n = 0 - do j = jsc, jec - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - ig = i + ocean_grid%isc - isc - n = n+1 - dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + n = 0 + do j = jsc, jec + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + ig = i + ocean_grid%isc - isc + n = n+1 + dataPtr1d(n) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo - if (present(areacor)) then - do n = 1,(size(dataPtr1d)) - dataPtr1d(n) = dataPtr1d(n) * areacor(n) - enddo - end if - - else if (geomtype == ESMF_GEOMTYPE_GRID) then - - call state_getfldptr(state, trim(fldname), dataptr2d, rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - lbnd1 = lbound(dataPtr2d,1) - lbnd2 = lbound(dataPtr2d,2) - - do j = jsc, jec - j1 = j + lbnd2 - jsc - jg = j + ocean_grid%jsc - jsc - do i = isc, iec - i1 = i + lbnd1 - isc - ig = i + ocean_grid%isc - isc - dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) - enddo + enddo + if (present(areacor)) then + do n = 1,(size(dataPtr1d)) + dataPtr1d(n) = dataPtr1d(n) * areacor(n) + enddo + end if + + else if (geomtype == ESMF_GEOMTYPE_GRID) then + + call state_getfldptr(state, trim(fldname), dataptr2d, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + lbnd1 = lbound(dataPtr2d,1) + lbnd2 = lbound(dataPtr2d,2) + + do j = jsc, jec + j1 = j + lbnd2 - jsc + jg = j + ocean_grid%jsc - jsc + do i = isc, iec + i1 = i + lbnd1 - isc + ig = i + ocean_grid%isc - isc + dataPtr2d(i1,j1) = input(i,j) * ocean_grid%mask2dT(ig,jg) enddo + enddo - endif + endif endif @@ -846,34 +846,34 @@ subroutine state_diagnose(State, string, rc) do n = 1, fieldCount - call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (lrank == 0) then - ! no local data - elseif (lrank == 1) then - if (size(dataPtr1d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & - minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - elseif (lrank == 2) then - if (size(dataPtr2d) > 0) then - write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & - minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) - else - write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" - endif - else - call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) - rc = ESMF_FAILURE - return - endif - call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) + call ESMF_StateGet(state, itemName=lfieldnamelist(n), field=lfield, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + call field_getfldptr(lfield, fldptr1=dataPtr1d, fldptr2=dataPtr2d, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (lrank == 0) then + ! no local data + elseif (lrank == 1) then + if (size(dataPtr1d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr1d), maxval(dataPtr1d), sum(dataPtr1d), size(dataPtr1d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + elseif (lrank == 2) then + if (size(dataPtr2d) > 0) then + write(msgString,'(A,3g14.7,i8)') trim(string)//': '//trim(lfieldnamelist(n)), & + minval(dataPtr2d), maxval(dataPtr2d), sum(dataPtr2d), size(dataPtr2d) + else + write(msgString,'(A,a)') trim(string)//': '//trim(lfieldnamelist(n))," no data" + endif + else + call ESMF_LogWrite(trim(subname)//": ERROR rank not supported ", ESMF_LOGMSG_ERROR) + rc = ESMF_FAILURE + return + endif + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO) enddo deallocate(lfieldnamelist) @@ -901,17 +901,17 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) ! ---------------------------------------------- if (.not.present(rc)) then - call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return + call ESMF_LogWrite(trim(subname)//": ERROR rc not present ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return endif rc = ESMF_SUCCESS labort = .true. if (present(abort)) then - labort = abort + labort = abort endif lrank = -99 @@ -919,69 +919,69 @@ subroutine field_getfldptr(field, fldptr1, fldptr2, rank, abort, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (status /= ESMF_FIELDSTATUS_COMPLETE) then - lrank = 0 - if (labort) then - call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) - rc = ESMF_FAILURE - return - else - call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) - endif + lrank = 0 + if (labort) then + call ESMF_LogWrite(trim(subname)//": ERROR data not allocated ", ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + else + call ESMF_LogWrite(trim(subname)//": WARNING data not allocated ", ESMF_LOGMSG_INFO) + endif else - call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - - if (geomtype == ESMF_GEOMTYPE_GRID) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - elseif (geomtype == ESMF_GEOMTYPE_MESH) then - call ESMF_FieldGet(field, rank=lrank, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_FieldGet(field, mesh=lmesh, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (nnodes == 0 .and. nelements == 0) lrank = 0 - else - call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & - ESMF_LOGMSG_INFO) + call ESMF_FieldGet(field, geomtype=geomtype, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (geomtype == ESMF_GEOMTYPE_GRID) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (geomtype == ESMF_GEOMTYPE_MESH) then + call ESMF_FieldGet(field, rank=lrank, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_FieldGet(field, mesh=lmesh, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_MeshGet(lmesh, numOwnedNodes=nnodes, numOwnedElements=nelements, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (nnodes == 0 .and. nelements == 0) lrank = 0 + else + call ESMF_LogWrite(trim(subname)//": ERROR geomtype not supported ", & + ESMF_LOGMSG_INFO) + rc = ESMF_FAILURE + return + endif ! geomtype + + if (lrank == 0) then + call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & + ESMF_LOGMSG_INFO) + elseif (lrank == 1) then + if (.not.present(fldptr1)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif ! geomtype - - if (lrank == 0) then - call ESMF_LogWrite(trim(subname)//": no local nodes or elements ", & - ESMF_LOGMSG_INFO) - elseif (lrank == 1) then - if (.not.present(fldptr1)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=1 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - elseif (lrank == 2) then - if (.not.present(fldptr2)) then - call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & - ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) - rc = ESMF_FAILURE - return - endif - call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - else - call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + endif + call ESMF_FieldGet(field, farrayPtr=fldptr1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + elseif (lrank == 2) then + if (.not.present(fldptr2)) then + call ESMF_LogWrite(trim(subname)//": ERROR missing rank=2 array ", & ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) rc = ESMF_FAILURE return - endif + endif + call ESMF_FieldGet(field, farrayPtr=fldptr2, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + else + call ESMF_LogWrite(trim(subname)//": ERROR in rank ", & + ESMF_LOGMSG_ERROR, line=__LINE__, file=u_FILE_u) + rc = ESMF_FAILURE + return + endif endif ! status if (present(rank)) then - rank = lrank + rank = lrank endif end subroutine field_getfldptr @@ -995,7 +995,7 @@ logical function ChkErr(rc, line, file) ChkErr = .false. lrc = rc if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=line, file=file)) then - ChkErr = .true. + ChkErr = .true. endif end function ChkErr diff --git a/config_src/drivers/nuopc_cap/mom_cap_time.F90 b/config_src/drivers/nuopc_cap/mom_cap_time.F90 index 7f210bda71..d8ae6892a9 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_time.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_time.F90 @@ -27,32 +27,32 @@ module MOM_cap_time ! Clock and alarm options character(len=*), private, parameter :: & - optNONE = "none" , & - optNever = "never" , & - optNSteps = "nsteps" , & - optNStep = "nstep" , & - optNSeconds = "nseconds" , & - optNSecond = "nsecond" , & - optNMinutes = "nminutes" , & - optNMinute = "nminute" , & - optNHours = "nhours" , & - optNHour = "nhour" , & - optNDays = "ndays" , & - optNDay = "nday" , & - optNMonths = "nmonths" , & - optNMonth = "nmonth" , & - optNYears = "nyears" , & - optNYear = "nyear" , & - optMonthly = "monthly" , & - optYearly = "yearly" , & - optDate = "date" , & - optIfdays0 = "ifdays0" , & - optGLCCouplingPeriod = "glc_coupling_period" + optNONE = "none" , & + optNever = "never" , & + optNSteps = "nsteps" , & + optNStep = "nstep" , & + optNSeconds = "nseconds" , & + optNSecond = "nsecond" , & + optNMinutes = "nminutes" , & + optNMinute = "nminute" , & + optNHours = "nhours" , & + optNHour = "nhour" , & + optNDays = "ndays" , & + optNDay = "nday" , & + optNMonths = "nmonths" , & + optNMonth = "nmonth" , & + optNYears = "nyears" , & + optNYear = "nyear" , & + optMonthly = "monthly" , & + optYearly = "yearly" , & + optDate = "date" , & + optIfdays0 = "ifdays0" , & + optGLCCouplingPeriod = "glc_coupling_period" ! Module data integer, parameter :: SecPerDay = 86400 ! Seconds per day character(len=*), parameter :: u_FILE_u = & - __FILE__ + __FILE__ contains @@ -66,7 +66,7 @@ module MOM_cap_time !! In the logic below we set an appropriate "NextAlarm" and then !! we make sure to advance it properly based on the ring interval. subroutine AlarmInit( clock, alarm, option, & - opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) + opt_n, opt_ymd, opt_tod, RefTime, alarmname, rc) type(ESMF_Clock) , intent(inout) :: clock !< ESMF clock type(ESMF_Alarm) , intent(inout) :: alarm !< ESMF alarm character(len=*) , intent(in) :: option !< alarm option @@ -109,20 +109,20 @@ subroutine AlarmInit( clock, alarm, option, & trim(option) == optNMonths .or. trim(option) == optNMonth .or. & trim(option) == optNYears .or. trim(option) == optNYear .or. & trim(option) == optIfdays0) then - if (.not. present(opt_n)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (opt_n <= 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' invalid opt_n', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif + if (.not. present(opt_n)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (opt_n <= 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' invalid opt_n', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif endif call ESMF_ClockGet(clock, CurrTime=CurrTime, rc=rc) @@ -136,9 +136,9 @@ subroutine AlarmInit( clock, alarm, option, & ! initial guess of next alarm, this will be updated below if (present(RefTime)) then - NextAlarm = RefTime + NextAlarm = RefTime else - NextAlarm = CurrTime + NextAlarm = CurrTime endif ! Determine calendar @@ -149,109 +149,109 @@ subroutine AlarmInit( clock, alarm, option, & selectcase (trim(option)) case (optNONE, optNever) - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=9999, mm=12, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optDate) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - if (lymd < 0 .or. ltod < 0) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .false. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + if (lymd < 0 .or. ltod < 0) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//'opt_ymd, opt_tod invalid', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, yy=9999, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call TimeInit(NextAlarm, lymd, cal, tod=ltod, desc="optDate", rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .false. case (optIfdays0) - if (.not. present(opt_ymd)) then - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//trim(option)//' requires opt_ymd', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return - endif - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + if (.not. present(opt_ymd)) then + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//trim(option)//' requires opt_ymd', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return + endif + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=opt_n, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNSteps, optNStep) - call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_ClockGet(clock, TimeStep=AlarmInterval, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNSeconds, optNSecond) - call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMinutes, optNMinute) - call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=60, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNHours, optNHour) - call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, s=3600, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNDays, optNDay) - call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, d=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optNMonths, optNMonth) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optMonthly) - call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, mm=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=cmm, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case (optNYears, optNYear) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - AlarmInterval = AlarmInterval * opt_n - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + AlarmInterval = AlarmInterval * opt_n + update_nextalarm = .true. case (optYearly) - call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - update_nextalarm = .true. + call ESMF_TimeIntervalSet(AlarmInterval, yy=1, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_TimeSet( NextAlarm, yy=cyy, mm=1, dd=1, s=0, calendar=cal, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + update_nextalarm = .true. case default - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' unknown option: '//trim(option), & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' unknown option: '//trim(option), & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return end select @@ -263,10 +263,10 @@ subroutine AlarmInit( clock, alarm, option, & ! --- most options above. go back one alarminterval just to be careful if (update_nextalarm) then - NextAlarm = NextAlarm - AlarmInterval - do while (NextAlarm <= CurrTime) - NextAlarm = NextAlarm + AlarmInterval - enddo + NextAlarm = NextAlarm - AlarmInterval + do while (NextAlarm <= CurrTime) + NextAlarm = NextAlarm + AlarmInterval + enddo endif alarm = ESMF_AlarmCreate( name=lalarmname, clock=clock, ringTime=NextAlarm, ringInterval=AlarmInterval, rc=rc) @@ -299,15 +299,15 @@ subroutine TimeInit( Time, ymd, cal, tod, desc, logunit, rc) if (present(desc)) ldesc = desc if ( (ymd < 0) .or. (ltod < 0) .or. (ltod > SecPerDay) )then - if (present(logunit)) then - write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & - 'time-of-day out of bounds', ymd, ltod - endif - call ESMF_LogSetError(ESMF_RC_ARG_BAD, & - msg=subname//' yymmdd is negative or time-of-day out of bounds ', & - line=__LINE__, & - file=__FILE__, rcToReturn=rc) - return + if (present(logunit)) then + write(logunit,*) subname//': ERROR yymmdd is a negative number or '// & + 'time-of-day out of bounds', ymd, ltod + endif + call ESMF_LogSetError(ESMF_RC_ARG_BAD, & + msg=subname//' yymmdd is negative or time-of-day out of bounds ', & + line=__LINE__, & + file=__FILE__, rcToReturn=rc) + return endif call date2ymd (ymd,yr,mon,day) @@ -330,7 +330,7 @@ subroutine date2ymd (date, year, month, day) tdate = abs(date) year = int(tdate/10000) if (date < 0) then - year = -year + year = -year endif month = int( mod(tdate,10000)/ 100) day = mod(tdate, 100) 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 448f23140e..a44e126461 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -724,38 +724,38 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) ! Is this needed? - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & - OS%dirs%restart_output_dir) - endif + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) ! Is this needed? + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & + OS%dirs%restart_output_dir) + endif else - if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) - endif - endif - if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) - call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir) - if (OS%use_ice_shelf) then - call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) - endif - endif + if (BTEST(OS%Restart_control,1)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, .true., GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir, .true.) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) + endif + endif + if (BTEST(OS%Restart_control,0)) then + call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & + OS%restart_CSp, GV=OS%GV) + call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & + OS%dirs%restart_output_dir) + if (OS%use_ice_shelf) then + call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) + endif + endif endif if (present(stoch_restartname)) then - if (OS%do_sppt .OR. OS%pert_epbl) then - call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) - endif + if (OS%do_sppt .OR. OS%pert_epbl) then + call write_stoch_restart_ocn('RESTART/'//trim(stoch_restartname)) + endif endif end subroutine ocean_model_restart @@ -839,9 +839,9 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) if (PRESENT(maskmap)) then - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else - call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) + call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) endif call mpp_get_compute_domain(Ocean_sfc%Domain, isc, iec, jsc, jec) @@ -1099,7 +1099,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. - call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) + call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select ! If the FMS coupler is changed so that Ocean_stock_PE is only called on 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 c704214930..da4c15e528 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -10,7 +10,6 @@ module MOM_surface_forcing_nuopc use MOM_diag_mediator, only : diag_ctrl use MOM_diag_mediator, only : safe_alloc_ptr, time_type use MOM_domains, only : pass_vector, pass_var, fill_symmetric_edges -use MOM_domains, only : global_field_sum, BITWISE_EXACT_SUM use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg @@ -316,9 +315,9 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%p_surf ,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%p_surf_full,isd,ied,jsd,jed) if (CS%use_limited_P_SSH) then - fluxes%p_surf_SSH => fluxes%p_surf + fluxes%p_surf_SSH => fluxes%p_surf else - fluxes%p_surf_SSH => fluxes%p_surf_full + fluxes%p_surf_SSH => fluxes%p_surf_full endif call safe_alloc_ptr(fluxes%salt_flux,isd,ied,jsd,jed) @@ -410,7 +409,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%salt_flux_added(is:ie,js:je) = fluxes%salt_flux(is:ie,js:je) ! Diagnostic else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss)*min(abs(delta_sss),CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & @@ -454,7 +453,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, return endif if (associated(IOB%lrunoff)) then - if(CS%liquid_runoff_from_data)call data_override('OCN', 'runoff', IOB%lrunoff, Time) + if (CS%liquid_runoff_from_data) call data_override('OCN', 'runoff', IOB%lrunoff, Time) endif ! obtain fluxes from IOB; note the staggering of indices @@ -504,30 +503,30 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice and snow melt heat flux [Q R Z T-1 ~> W/m2] if (associated(IOB%seaice_melt_heat)) & - fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) + fluxes%seaice_melt_heat(i,j) = US%W_m2_to_QRZ_T * G%mask2dT(i,j) * IOB%seaice_melt_heat(i-i0,j-j0) ! water flux due to sea ice and snow melt [kg/m2/s] if (associated(IOB%seaice_melt)) & - fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) + fluxes%seaice_melt(i,j) = kg_m2_s_conversion * G%mask2dT(i,j) * IOB%seaice_melt(i-i0,j-j0) fluxes%latent(i,j) = 0.0 ! notice minus sign since fprec is positive into the ocean if (associated(IOB%fprec)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion - fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion + fluxes%latent_fprec_diag(i,j) = - G%mask2dT(i,j) * IOB%fprec(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_fusion endif ! notice minus sign since frunoff is positive into the ocean if (associated(IOB%frunoff)) then - fluxes%latent(i,j) = fluxes%latent(i,j) - & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion - fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & - IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent(i,j) = fluxes%latent(i,j) - & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion + fluxes%latent_frunoff_diag(i,j) = - G%mask2dT(i,j) * & + IOB%frunoff(i-i0,j-j0) * US%W_m2_to_QRZ_T * CS%latent_heat_fusion endif if (associated(IOB%q_flux)) then - fluxes%latent(i,j) = fluxes%latent(i,j) + & - IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor - fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent(i,j) = fluxes%latent(i,j) + & + IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor + fluxes%latent_evap_diag(i,j) = G%mask2dT(i,j) * IOB%q_flux(i-i0,j-j0)*US%W_m2_to_QRZ_T*CS%latent_heat_vapor endif fluxes%latent(i,j) = G%mask2dT(i,j) * fluxes%latent(i,j) @@ -548,10 +547,10 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! sea ice fraction [nondim] if (associated(IOB%ice_fraction) .and. associated(fluxes%ice_fraction)) & - fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) + fluxes%ice_fraction(i,j) = G%mask2dT(i,j) * IOB%ice_fraction(i-i0,j-j0) ! 10-m wind speed squared [m2/s2] if (associated(IOB%u10_sqr) .and. associated(fluxes%u10_sqr)) & - fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) + fluxes%u10_sqr(i,j) = US%m_to_L**2 * US%T_to_s**2 * G%mask2dT(i,j) * IOB%u10_sqr(i-i0,j-j0) enddo ; enddo @@ -569,18 +568,18 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! applied surface pressure from atmosphere and cryosphere if (associated(IOB%p)) then - if (CS%max_p_surf >= 0.0) then - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) - enddo; enddo - else - do j=js,je ; do i=is,ie - fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) - fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) - enddo; enddo - endif - fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. + if (CS%max_p_surf >= 0.0) then + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = MIN(fluxes%p_surf_full(i,j),CS%max_p_surf) + enddo ; enddo + else + do j=js,je ; do i=is,ie + fluxes%p_surf_full(i,j) = G%mask2dT(i,j) * US%kg_m3_to_R*US%m_s_to_L_T**2*IOB%p(i-i0,j-j0) + fluxes%p_surf(i,j) = fluxes%p_surf_full(i,j) + enddo ; enddo + endif + fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif ! CFCs @@ -734,9 +733,9 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! applied surface pressure from atmosphere and cryosphere if (CS%use_limited_P_SSH) then - forces%p_surf_SSH => forces%p_surf + forces%p_surf_SSH => forces%p_surf else - forces%p_surf_SSH => forces%p_surf_full + forces%p_surf_SSH => forces%p_surf_full endif if (associated(IOB%p)) then if (CS%max_p_surf >= 0.0) then @@ -806,7 +805,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) > 0.0) & forces%taux(I,j) = (G%mask2dBu(I,J)*taux_at_q(I,J) + & G%mask2dBu(I,J-1)*taux_at_q(I,J-1)) / & (G%mask2dBu(I,J) + G%mask2dBu(I,J-1)) @@ -814,7 +813,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0) & + if ((G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) > 0.0) & forces%tauy(i,J) = (G%mask2dBu(I,J)*tauy_at_q(I,J) + & G%mask2dBu(I-1,J)*tauy_at_q(I-1,J)) / & (G%mask2dBu(I,J) + G%mask2dBu(I-1,J)) @@ -827,7 +826,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie tau_mag = 0.0 ; gustiness = CS%gust_const if (((G%mask2dBu(I,J) + G%mask2dBu(I-1,J-1)) + & - (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0) then + (G%mask2dBu(I,J-1) + G%mask2dBu(I-1,J))) > 0.0) then tau_mag = sqrt(((G%mask2dBu(I,J)*(taux_at_q(I,J)**2 + tauy_at_q(I,J)**2) + & G%mask2dBu(I-1,J-1)*(taux_at_q(I-1,J-1)**2 + tauy_at_q(I-1,J-1)**2)) + & (G%mask2dBu(I,J-1)*(taux_at_q(I,J-1)**2 + tauy_at_q(I,J-1)**2) + & @@ -843,7 +842,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do I=Isq,Ieq forces%taux(I,j) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j)) > 0.0) & forces%taux(I,j) = (G%mask2dT(i,j)*taux_at_h(i,j) + & G%mask2dT(i+1,j)*taux_at_h(i+1,j)) / & (G%mask2dT(i,j) + G%mask2dT(i+1,j)) @@ -851,7 +850,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do J=Jsq,Jeq ; do i=is,ie forces%tauy(i,J) = 0.0 - if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0) & + if ((G%mask2dT(i,j) + G%mask2dT(i,j+1)) > 0.0) & forces%tauy(i,J) = (G%mask2dT(i,j)*tauy_at_h(i,j) + & G%mask2dT(i,J+1)*tauy_at_h(i,j+1)) / & (G%mask2dT(i,j) + G%mask2dT(i,j+1)) @@ -859,7 +858,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie gustiness = CS%gust_const - if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) + if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0.0)) gustiness = CS%gust(i,j) 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)) enddo ; enddo @@ -871,12 +870,12 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j)*forces%taux(I-1,j)**2 + & G%mask2dCu(I,j)*forces%taux(I,j)**2) / (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1)*forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J)*forces%tauy(i,J)**2) / (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 300c736802..fa1d7f5701 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -77,8 +77,6 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! are in W m-2 and positive for heat going into the ocean. All fresh water ! fluxes are in kg m-2 s-1 and positive for water moving into the ocean. - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt] real :: density_restore ! The potential density that is being restored toward [R ~> kg m-3]. real :: rhoXcp ! The mean density times the heat capacity [Q R degC-1 ~> J m-3 degC-1]. real :: buoy_rest_const ! A constant relating density anomalies to the @@ -172,7 +170,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 1b88f1ce36..d6630a0f17 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -26,6 +26,7 @@ program MOM_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT + use MOM_data_override, only : data_override_init use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end @@ -47,6 +48,7 @@ program MOM_main use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS 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_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 @@ -127,7 +129,6 @@ program MOM_main ! representation of dt_forcing. real :: dt_forcing ! The coupling time step [s]. real :: dt ! The nominal baroclinic dynamics time step [s]. - real :: dt_off ! Offline time step [s]. integer :: ntstep ! The number of baroclinic dynamics time steps ! within dt_forcing. real :: dt_therm ! The thermodynamic timestep [s] @@ -176,12 +177,14 @@ program MOM_main type(surface_forcing_CS), pointer :: surface_forcing_CSp => NULL() type(write_cputime_CS), pointer :: write_CPU_CSp => NULL() type(ice_shelf_CS), pointer :: ice_shelf_CSp => NULL() + logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, + !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() type(MOM_restart_CS), pointer :: & restart_CSp => NULL() !< A pointer to the restart control structure !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & - diag => NULL() !< A pointer to the diagnostic regulatory structure + diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- character(len=4), parameter :: vers_num = 'v2.0' @@ -302,6 +305,8 @@ program MOM_main ! when using an ice shelf call initialize_ice_shelf_fluxes(ice_shelf_CSp, grid, US, fluxes) 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) endif diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7c26c2f194..6de59684b7 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -298,7 +298,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable winds defined with no wind config") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing:Unrecognized wind config "//trim(CS%wind_config)) endif endif @@ -338,7 +338,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call MOM_error(FATAL, & "MOM_surface_forcing: Variable buoy defined with no buoy config.") else - call MOM_error(FATAL, & + call MOM_error(FATAL, & "MOM_surface_forcing: Unrecognized buoy config "//trim(CS%buoy_config)) endif endif @@ -1125,7 +1125,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1138,7 +1138,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1231,7 +1231,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (CS%restorebuoy) then if (CS%use_temperature) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & @@ -1244,7 +1244,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US enddo ; enddo else do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & (CS%G_Earth * CS%Flux_const / CS%Rho0) else @@ -1431,7 +1431,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) y = (G%geoLatCu(I,j)-CS%South_lat)/CS%len_lat T_restore = CS%T_south + (CS%T_north-CS%T_south)*y S_restore = CS%S_south + (CS%S_north-CS%S_south)*y - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & @@ -1446,7 +1446,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "buoyancy_forcing_linear in MOM_surface_forcing: "// & "RESTOREBUOY to linear not written yet.") !do j=js,je ; do i=is,ie - ! if (G%mask2dT(i,j) > 0) then + ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & ! (CS%G_Earth * CS%Flux_const / CS%Rho0) ! else diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 index e50f2ccf0b..b7ee7de684 100644 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -11,9 +11,9 @@ module FMS_coupler_util !> Get element and index of a boundary condition subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb, jlb, & is, ie, js, je, conversion) - real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values integer, intent(in) :: ilb !< Lower bounds integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:),intent(out) :: array_out !< The array being filled with the input values type(coupler_2d_bc_type), intent(in) :: BC_struc !< The type from which the data is being extracted integer, intent(in) :: BC_index !< The boundary condition number being extracted integer, intent(in) :: BC_element !< The element of the boundary condition being extracted @@ -27,9 +27,9 @@ end subroutine extract_coupler_values !> Set element and index of a boundary condition subroutine set_coupler_values(array_in, BC_struc, BC_index, BC_element, ilb, jlb,& is, ie, js, je, conversion) - real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC integer, intent(in) :: ilb !< Lower bounds integer, intent(in) :: jlb !< Lower bounds + real, dimension(ilb:,jlb:), intent(in) :: array_in !< The array containing the values to load into the BC type(coupler_2d_bc_type), intent(inout) :: BC_struc !< The type into which the data is being loaded integer, intent(in) :: BC_index !< The boundary condition number being set integer, intent(in) :: BC_element !< The element of the boundary condition being set diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 index 6bd445ae8b..42c386497a 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer.F90 @@ -69,13 +69,13 @@ end subroutine generic_tracer_coupler_accumulate subroutine generic_tracer_source(Temp,Salt,rho_dzt,dzt,hblt_depth,ilb,jlb,tau,dtts,& grid_dat,model_time,nbands,max_wavelength_band,sw_pen_band,opacity_band,internal_heat,& frunoff,grid_ht, current_wave_stress, sosga) + integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain + integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain real, dimension(ilb:,jlb:,:), intent(in) :: Temp !< Potential temperature [deg C] real, dimension(ilb:,jlb:,:), intent(in) :: Salt !< Salinity [psu] real, dimension(ilb:,jlb:,:), intent(in) :: rho_dzt !< Mass per unit area of each layer [kg m-2] real, dimension(ilb:,jlb:,:), intent(in) :: dzt !< Ocean layer thickness [m] real, dimension(ilb:,jlb:), intent(in) :: hblt_depth !< Boundary layer depth [m] - integer, intent(in) :: ilb !< Lower bounds of x extent of input arrays on data domain - integer, intent(in) :: jlb !< Lower bounds of y extent of input arrays on data domain integer, intent(in) :: tau !< Time step index of %field real, intent(in) :: dtts !< The time step for this call [s] real, dimension(ilb:,jlb:), intent(in) :: grid_dat !< Grid cell areas [m2] diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index de513a7f11..cbc310eb7d 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -185,7 +185,6 @@ subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,posi integer, optional, intent(in) :: ntau !< Unknown logical, optional, intent(in) :: positive !< Unknown real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown - integer :: tau character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' end subroutine g_tracer_get_3D_val @@ -257,7 +256,6 @@ end subroutine g_tracer_set_real subroutine g_tracer_send_diag(g_tracer_list,model_time,tau) type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list - type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node type(time_type), intent(in) :: model_time !< Time integer, intent(in) :: tau !< The time step for the %field 4D field to be reported end subroutine g_tracer_send_diag diff --git a/config_src/external/ODA_hooks/ocean_da_types.F90 b/config_src/external/ODA_hooks/ocean_da_types.F90 index e71c76a048..a99f1ae669 100644 --- a/config_src/external/ODA_hooks/ocean_da_types.F90 +++ b/config_src/external/ODA_hooks/ocean_da_types.F90 @@ -1,90 +1,88 @@ !> Dummy aata structures and methods for ocean data assimilation. module ocean_da_types_mod - use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type - implicit none +implicit none ; private - private +!> Example type for ocean ensemble DA state +type, public :: OCEAN_CONTROL_STRUCT + integer :: ensemble_size !< ensemble size + real, pointer, dimension(:,:,:) :: SSH => NULL() !< sea surface height across ensembles [m] + real, pointer, dimension(:,:,:,:) :: h => NULL() !< layer thicknesses across ensembles [m or kg m-2] + real, pointer, dimension(:,:,:,:) :: T => NULL() !< layer potential temperature across ensembles [degC] + real, pointer, dimension(:,:,:,:) :: S => NULL() !< layer salinity across ensembles [ppt] + real, pointer, dimension(:,:,:,:) :: U => NULL() !< layer zonal velocity across ensembles [m s-1] + real, pointer, dimension(:,:,:,:) :: V => NULL() !< layer meridional velocity across ensembles [m s-1] +end type OCEAN_CONTROL_STRUCT - !> Example type for ocean ensemble DA state - type, public :: OCEAN_CONTROL_STRUCT - integer :: ensemble_size !< ensemble size - real, pointer, dimension(:,:,:) :: SSH=>NULL() !NULL() !NULL() !NULL() !NULL() !NULL() ! Example of a profile type +type, public :: ocean_profile_type + integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) + logical :: initialized !< a True value indicates that this profile has been allocated for use + logical :: colocated !< a True value indicated that the measurements of (num_variables) data are + !! co-located in space-time + integer :: ensemble_size !< size of the ensemble of model states used in association with this profile + integer :: num_variables !< number of measurement types associated with this profile. + integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module + integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) + !! and instrument type (XBT, CDT, etc.) + integer :: levels !< number of levels in the current profile + integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, + !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, + !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf + integer :: profile_flag !< an overall flag for the profile + real :: lat !< latitude [degrees_N] + real :: lon !< longitude [degrees_E] + logical :: accepted !< logical flag to disable a profile + type(time_type) :: time_window !< The time window associated with this profile + real, pointer, dimension(:) :: obs_error !< The observation error by variable [various units] + real :: loc_dist !< The impact radius of this observation [m] + type(ocean_profile_type), pointer :: next => NULL() !< all profiles are stored as linked list. + type(ocean_profile_type), pointer :: prev => NULL() !< previous + type(ocean_profile_type), pointer :: cnext => NULL() !< current profiles are stored as linked list. + type(ocean_profile_type), pointer :: cprev => NULL() !< previous + integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile + integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile + real :: nbr_dist !< distance to nearest neighbor model gridpoint [m] + logical :: compute !< profile is within current compute domain + real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] + real, dimension(:,:), pointer :: data => NULL() !< data by variable type [various units] + integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type + real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess + real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis + type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator + type(time_type) :: time !< profile time type + real :: i_index !< model longitude indices respectively + real :: j_index !< model latitude indices respectively + real, dimension(:,:), pointer :: k_index !< model depth indices + type(time_type) :: tdiff !< difference between model time and observation time + character(len=128) :: filename !< a filename +end type ocean_profile_type - !> Example of a profile type - type, public :: ocean_profile_type - integer :: inst_type !< A numeric code indicating the type of instrument (e.g. ARGO drifter, CTD, ...) - logical :: initialized !< a True value indicates that this profile has been allocated for use - logical :: colocated !< a True value indicated that the measurements of (num_variables) data are - !! co-located in space-time - integer :: ensemble_size !< size of the ensemble of model states used in association with this profile - integer :: num_variables !< number of measurement types associated with this profile. - integer, pointer, dimension(:) :: var_id !< variable ids are defined by the ocean_types module - integer :: platform !< platform types are defined by platform class (e.g. MOORING, DROP, etc.) - !! and instrument type (XBT, CDT, etc.) - integer :: levels !< number of levels in the current profile - integer :: basin_mask !< 1:Southern Ocean, 2:Atlantic Ocean, 3:Pacific Ocean, - !! 4:Arctic Ocean, 5:Indian Ocean, 6:Mediterranean Sea, 7:Black Sea, - !! 8:Hudson Bay, 9:Baltic Sea, 10:Red Sea, 11:Persian Gulf - integer :: profile_flag !< an overall flag for the profile - real :: lat !< latitude [degrees_N] - real :: lon !< longitude [degrees_E] - logical :: accepted !< logical flag to disable a profile - type(time_type) :: time_window !< The time window associated with this profile [s] - real, pointer, dimension(:) :: obs_error !< The observation error by variable - real :: loc_dist !< The impact radius of this observation (m) - type(ocean_profile_type), pointer :: next=>NULL() !< all profiles are stored as linked list. - type(ocean_profile_type), pointer :: prev=>NULL() !< previous - type(ocean_profile_type), pointer :: cnext=>NULL() !< current profiles are stored as linked list. - type(ocean_profile_type), pointer :: cprev=>NULL() !< previous - integer :: nbr_xi !< x nearest neighbor model gridpoint for the profile - integer :: nbr_yi !< y nearest neighbor model gridpoint for the profile - real :: nbr_dist !< distance to nearest neighbor model gridpoint - logical :: compute !< profile is within current compute domain - real, dimension(:,:), pointer :: depth => NULL() !< depth of measurement [m] - real, dimension(:,:), pointer :: data => NULL() !< data by variable type - integer, dimension(:,:), pointer :: flag => NULL() !< flag by depth and variable type - real, dimension(:,:,:), pointer :: forecast => NULL() !< ensemble member first guess - real, dimension(:,:,:), pointer :: analysis => NULL() !< ensemble member analysis - type(forward_operator_type), pointer :: obs_def => NULL() !< observation forward operator - type(time_type) :: time !< profile time type - real :: i_index !< model longitude indices respectively - real :: j_index !< model latitude indices respectively - real, dimension(:,:), pointer :: k_index !< model depth indices - type(time_type) :: tdiff !< difference between model time and observation time - character(len=128) :: filename !< a filename - end type ocean_profile_type +!> Example forward operator type. +type, public :: forward_operator_type + integer :: num !< how many? + integer, dimension(2) :: state_size !< for + integer, dimension(:), pointer :: state_var_index !< for flattened data + integer, dimension(:), pointer :: i_index !< i-dimension index + integer, dimension(:), pointer :: j_index !< j-dimension index + real, dimension(:), pointer :: coef !< coefficient +end type forward_operator_type - !> Example forward operator type. - type, public :: forward_operator_type - integer :: num !< how many? - integer, dimension(2) :: state_size !< for - integer, dimension(:), pointer :: state_var_index !< for flattened data - integer, dimension(:), pointer :: i_index !< i-dimension index - integer, dimension(:), pointer :: j_index !< j-dimension index - real, dimension(:), pointer :: coef !< coefficient - end type forward_operator_type - - !> Grid type for DA - type, public :: grid_type - real, pointer, dimension(:,:) :: x=>NULL() !< x - real, pointer, dimension(:,:) :: y=>NULL() !< y - real, pointer, dimension(:,:,:) :: z=>NULL() !< z - real, pointer, dimension(:,:,:) :: h=>NULL() !< h - real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask - real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? - real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points - logical :: tripolar_N !< True for tripolar grids - integer :: ni !< ni - integer :: nj !< nj - integer :: nk !< nk - end type grid_type +!> Grid type for DA +type, public :: grid_type + real, pointer, dimension(:,:) :: x => NULL() !< x + real, pointer, dimension(:,:) :: y => NULL() !< y + real, pointer, dimension(:,:,:) :: z => NULL() !< z + real, pointer, dimension(:,:,:) :: h => NULL() !< h + real, pointer, dimension(:,:) :: basin_mask => NULL() !< basin mask + real, pointer, dimension(:,:,:) :: mask => NULL() !< land mask? + real, pointer, dimension(:,:) :: bathyT => NULL() !< bathymetry at T points [m] + logical :: tripolar_N !< True for tripolar grids + integer :: ni !< ni + integer :: nj !< nj + integer :: nk !< nk +end type grid_type end module ocean_da_types_mod diff --git a/config_src/external/ODA_hooks/write_ocean_obs.F90 b/config_src/external/ODA_hooks/write_ocean_obs.F90 index da4a404d3d..51b5d2a1d7 100644 --- a/config_src/external/ODA_hooks/write_ocean_obs.F90 +++ b/config_src/external/ODA_hooks/write_ocean_obs.F90 @@ -1,16 +1,12 @@ !> Dummy interfaces for writing ODA data module write_ocean_obs_mod +use ocean_da_types_mod, only : ocean_profile_type +use MOM_time_manager, only : time_type, get_time, set_date - use ocean_da_types_mod, only : ocean_profile_type - use MOM_time_manager, only : time_type, get_time, set_date +implicit none ; private - implicit none - - private - - public :: open_profile_file, write_profile, close_profile_file, & - write_ocean_obs_init +public :: open_profile_file, write_profile, close_profile_file, write_ocean_obs_init contains diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index 135f5d284c..aad918e5a4 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -1,26 +1,28 @@ !> A set of dummy interfaces for compiling the MOM6 drifters code module MOM_particles_mod +! This file is part of MOM6. See LICENSE.md for the license. + use MOM_grid, only : ocean_grid_type use MOM_time_manager, only : time_type, get_date, operator(-) use MOM_variables, only : thermo_var_ptrs +use particles_types_mod, only : particles, particles_gridded +implicit none ; private -use particles_types_mod, only: particles, particles_gridded - -public particles_run, particles_init, particles_save_restart, particles_end +public particles, particles_run, particles_init, particles_save_restart, particles_end contains !> Initializes particles container "parts" subroutine particles_init(parts, Grid, Time, dt, u, v) ! Arguments - type(particles), pointer, intent(out) :: parts !< Container for all types and memory - type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model - type(time_type), intent(in) :: Time !< Time type from parent model - real, intent(in) :: dt !< particle timestep in seconds - real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field - real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field + type(particles), pointer, intent(out) :: parts !< Container for all types and memory + type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model + type(time_type), intent(in) :: Time !< Time type from parent model + real, intent(in) :: dt !< particle timestep [s] + real, dimension(:,:,:), intent(in) :: u !< Zonal velocity field [m s-1] + real, dimension(:,:,:), intent(in) :: v !< Meridional velocity field [m s-1] end subroutine particles_init @@ -29,30 +31,30 @@ subroutine particles_run(parts, time, uo, vo, ho, tv, 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 (m/s) - real, dimension(:,:,:),intent(in) :: vo !< Ocean meridional velocity (m/s) - 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 + real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [m s-1] + real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [m s-1] + 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 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,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_save_restart(parts, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity end subroutine particles_save_restart !> Deallocate all memory and disassociated pointer -subroutine particles_end(parts,temp,salt) -! Arguments -type(particles), pointer :: parts !< Container for all types and memory -real,dimension(:,:,:),optional,intent(in) :: temp !< Optional container for temperature -real,dimension(:,:,:),optional,intent(in) :: salt !< Optional container for salinity +subroutine particles_end(parts, temp, salt) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity end subroutine particles_end diff --git a/config_src/external/drifters/MOM_particles_types.F90 b/config_src/external/drifters/MOM_particles_types.F90 index b7bc01acb9..51e744a186 100644 --- a/config_src/external/drifters/MOM_particles_types.F90 +++ b/config_src/external/drifters/MOM_particles_types.F90 @@ -1,12 +1,15 @@ !> Dummy data structures and methods for drifters package module particles_types_mod +! This file is part of MOM6. See LICENSE.md for the license. + use MOM_grid, only : ocean_grid_type -use mpp_domains_mod, only: domain2D +use MOM_domains, only: domain2D +implicit none ; private !> Container for gridded fields -type :: particles_gridded +type, public :: particles_gridded type(domain2D), pointer :: domain !< MPP parallel domain integer :: halo !< Nominal halo width integer :: isc !< Start i-index of computational domain @@ -60,7 +63,7 @@ module particles_types_mod !>xyt is a data structure containing particle position and velocity fields. -type :: xyt +type, public :: xyt real :: lon !< Longitude of particle (degree N or unit of grid coordinate) real :: lat !< Latitude of particle (degree N or unit of grid coordinate) real :: day !< Day of this record (days) @@ -77,7 +80,7 @@ module particles_types_mod end type xyt !>particle types are data structures describing a tracked particle -type :: particle +type, public :: particle type(particle), pointer :: prev=>null() !< Previous link in list type(particle), pointer :: next=>null() !< Next link in list ! State variables (specific to the particles, needed for restarts) @@ -109,19 +112,19 @@ module particles_types_mod !>A buffer structure for message passing -type :: buffer +type, public :: buffer integer :: size=0 !< Size of buffer real, dimension(:,:), pointer :: data !< Buffer memory end type buffer !> A wrapper for the particle linked list (since an array of pointers is not allowed) -type :: linked_list +type, public :: linked_list type(particle), pointer :: first=>null() !< Pointer to the beginning of a linked list of parts end type linked_list !> A grand data structure for the particles in the local MOM domain -type :: particles !; private +type, public :: particles !; private type(particles_gridded) :: grd !< Container with all gridded data type(linked_list), dimension(:,:), allocatable :: list !< Linked list of particles type(xyt), pointer :: trajectories=>null() !< A linked list for detached segments of trajectories diff --git a/config_src/external/stochastic_physics/get_stochy_pattern.F90 b/config_src/external/stochastic_physics/get_stochy_pattern.F90 new file mode 100644 index 0000000000..c3e23cd1a4 --- /dev/null +++ b/config_src/external/stochastic_physics/get_stochy_pattern.F90 @@ -0,0 +1,22 @@ +! The are stubs for ocean stochastic physics +! the fully functional code is available at +! http://github.com/noaa-psd/stochastic_physics +module get_stochy_pattern_mod + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public :: write_stoch_restart_ocn + +contains + +!> Write the restart file for the stochastic physics perturbations. +subroutine write_stoch_restart_ocn(sfile) + character(len=*) :: sfile !< name of restart file + + ! This stub function does not actually do anything. + return +end subroutine write_stoch_restart_ocn + +end module get_stochy_pattern_mod diff --git a/config_src/external/stochastic_physics/stochastic_physics.F90 b/config_src/external/stochastic_physics/stochastic_physics.F90 index df62aa1591..14fa1bf289 100644 --- a/config_src/external/stochastic_physics/stochastic_physics.F90 +++ b/config_src/external/stochastic_physics/stochastic_physics.F90 @@ -3,66 +3,56 @@ ! http://github.com/noaa-psd/stochastic_physics module stochastic_physics -implicit none +! This file is part of MOM6. See LICENSE.md for the license. -private +use MOM_error_handler, only : MOM_error, WARNING + +implicit none ; private public :: init_stochastic_physics_ocn public :: run_stochastic_physics_ocn contains -!!!!!!!!!!!!!!!!!!!! -subroutine init_stochastic_physics_ocn(delt,geoLonT,geoLatT,nx,ny,nz,pert_epbl_in,do_sppt_in, & +!> Initializes the stochastic physics perturbations. +subroutine init_stochastic_physics_ocn(delt, geoLonT, geoLatT, nx, ny, nz, pert_epbl_in, do_sppt_in, & mpiroot, mpicomm, iret) -implicit none -real,intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn -integer,intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid -integer,intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid -integer,intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid -real,intent(in) :: geoLonT(nx,ny) !< Longitude in degrees -real,intent(in) :: geoLatT(nx,ny) !< Latitude in degrees -logical,intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations -logical,intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations -integer,intent(in) :: mpiroot !< root processor -integer,intent(in) :: mpicomm !< mpi communicator -integer, intent(out) :: iret !< return code - -iret=0 -if (pert_epbl_in .EQV. .true. ) then - print*,'pert_epbl needs to be false if using the stub' - iret=-1 -endif -if (do_sppt_in.EQV. .true. ) then - print*,'do_sppt needs to be false if using the stub' - iret=-1 -endif -return + real, intent(in) :: delt !< timestep in seconds between calls to run_stochastic_physics_ocn [s] + integer, intent(in) :: nx !< number of gridpoints in the x-direction of the compute grid + integer, intent(in) :: ny !< number of gridpoints in the y-direction of the compute grid + integer, intent(in) :: nz !< number of gridpoints in the z-direction of the compute grid + real, intent(in) :: geoLonT(nx,ny) !< Longitude in degrees + real, intent(in) :: geoLatT(nx,ny) !< Latitude in degrees + logical, intent(in) :: pert_epbl_in !< logical flag, if true generate random pattern for ePBL perturbations + logical, intent(in) :: do_sppt_in !< logical flag, if true generate random pattern for SPPT perturbations + integer, intent(in) :: mpiroot !< root processor + integer, intent(in) :: mpicomm !< mpi communicator + integer, intent(out) :: iret !< return code + + iret=0 + if (pert_epbl_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: pert_epbl needs to be false if using the stub') + iret=-1 + endif + if (do_sppt_in) then + call MOM_error(WARNING, 'init_stochastic_physics_ocn: do_sppt needs to be false if using the stub') + iret=-1 + endif + + ! This stub function does not actually do anything. + return end subroutine init_stochastic_physics_ocn -subroutine run_stochastic_physics_ocn(sppt_wts,t_rp1,t_rp2) -implicit none -real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] -real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL - !! perturbations (KE generation) range [0,2] -real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL - !! perturbations (KE dissipation) range [0,2] -return +!> Determines the stochastic physics perturbations. +subroutine run_stochastic_physics_ocn(sppt_wts, t_rp1, t_rp2) + real, intent(inout) :: sppt_wts(:,:) !< array containing random weights for SPPT range [0,2] + real, intent(inout) :: t_rp1(:,:) !< array containing random weights for ePBL + !! perturbations (KE generation) range [0,2] + real, intent(inout) :: t_rp2(:,:) !< array containing random weights for ePBL + !! perturbations (KE dissipation) range [0,2] + + ! This stub function does not actually do anything. + return end subroutine run_stochastic_physics_ocn end module stochastic_physics - -module get_stochy_pattern_mod - -private - -public :: write_stoch_restart_ocn - -contains -subroutine write_stoch_restart_ocn(sfile) - -character(len=*) :: sfile !< name of restart file -return -end subroutine write_stoch_restart_ocn - -end module get_stochy_pattern_mod diff --git a/config_src/infra/FMS1/MOM_coms_infra.F90 b/config_src/infra/FMS1/MOM_coms_infra.F90 index 555b4df119..561cf6c333 100644 --- a/config_src/infra/FMS1/MOM_coms_infra.F90 +++ b/config_src/infra/FMS1/MOM_coms_infra.F90 @@ -16,6 +16,7 @@ module MOM_coms_infra public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -438,6 +439,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> Initialize the model framework, including PE communication over a designated communicator. !! If no communicator ID is provided, the framework's default communicator is used. subroutine MOM_infra_init(localcomm) diff --git a/config_src/infra/FMS1/MOM_couplertype_infra.F90 b/config_src/infra/FMS1/MOM_couplertype_infra.F90 index 3bcccc1dc7..637f2b5ebf 100644 --- a/config_src/infra/FMS1/MOM_couplertype_infra.F90 +++ b/config_src/infra/FMS1/MOM_couplertype_infra.F90 @@ -409,8 +409,6 @@ subroutine CT_set_data(array_in, bc_index, field_index, var, & !! the second dimension of the output array !! in a non-decreasing list - integer :: subfield ! An integer indicating which field to set. - call coupler_type_set_data(array_in, bc_index, field_index, var, scale_factor, halo_size, idim, jdim) end subroutine CT_set_data diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index c588628cbc..18ccdaae67 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 7eff4597f3..470dde0848 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var @@ -241,8 +241,8 @@ subroutine pass_var_2d(array, MOM_dom, sideflag, complete, position, halo, inner ! Local variables real, allocatable, dimension(:,:) :: tmp integer :: pos, i_halo, j_halo - integer :: isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB - integer :: inner, i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn + integer :: isc, iec, jsc, jec, isd, ied, jsd, jed + integer :: i, j, isfw, iefw, isfe, iefe, jsfs, jefs, jsfn, jefn integer :: dirflag logical :: block_til_complete @@ -593,7 +593,6 @@ subroutine fill_vector_symmetric_edges_2d(u_cmpt, v_cmpt, MOM_dom, stagger, scal integer :: dirflag integer :: i, j, isc, iec, jsc, jec, isd, ied, jsd, jed, IscB, IecB, JscB, JecB real, allocatable, dimension(:) :: sbuff_x, sbuff_y, wbuff_x, wbuff_y - logical :: block_til_complete if (.not. MOM_dom%symmetric) then return @@ -1328,10 +1327,8 @@ subroutine create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, l !! nonblocking halo updates, or false if missing. ! local variables - integer, dimension(4) :: global_indices ! The lower and upper global i- and j-index bounds integer :: X_FLAGS ! A combination of integers encoding the x-direction grid connectivity. integer :: Y_FLAGS ! A combination of integers encoding the y-direction grid connectivity. - integer :: xhalo_d2, yhalo_d2 character(len=200) :: mesg ! A string for use in error messages logical :: mask_table_exists ! Mask_table is present and the file it points to exists @@ -1516,7 +1513,6 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain integer, optional, intent(in) :: extra_halo !< An extra number of points in the halos !! compared with MD_in - integer :: global_indices(4) logical :: mask_table_exists integer, dimension(:), allocatable :: exni ! The extents of the grid for each i-row of the layout. ! The sum of exni must equal MOM_dom%niglobal. @@ -1819,7 +1815,7 @@ subroutine get_domain_extent_d2D(Domain, isc, iec, jsc, jec, isd, ied, jsd, jed) integer, optional, intent(out) :: jed !< The end j-index of the data domain ! Local variables - integer :: isd_, ied_, jsd_, jed_, jsg_, jeg_, isg_, ieg_ + integer :: isd_, ied_, jsd_, jed_ call mpp_get_compute_domain(Domain, isc, iec, jsc, jec) call mpp_get_data_domain(Domain, isd_, ied_, jsd_, jed_) @@ -1906,14 +1902,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays diff --git a/config_src/infra/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 774f6a67d2..224e26a051 100644 --- a/config_src/infra/FMS1/MOM_interp_infra.F90 +++ b/config_src/infra/FMS1/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ module MOM_interp_infra implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & diff --git a/config_src/infra/FMS1/MOM_io_infra.F90 b/config_src/infra/FMS1/MOM_io_infra.F90 index f956f9fa51..c0ccfcbcc8 100644 --- a/config_src/infra/FMS1/MOM_io_infra.F90 +++ b/config_src/infra/FMS1/MOM_io_infra.F90 @@ -715,9 +715,8 @@ subroutine read_field_4d(filename, fieldname, data, MOM_Domain, & ! Local variables character(len=80) :: varname ! The name of a variable in the file type(fieldtype), allocatable :: fields(:) ! An array of types describing all the variables in the file - logical :: use_fms_read_data, file_is_global + logical :: file_is_global integer :: n, unit, ndim, nvar, natt, ntime - integer :: is, ie, js, je ! This single call does not work for a 4-d array due to FMS limitations, so multiple calls are ! needed. diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index 555b4df119..561cf6c333 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -16,6 +16,7 @@ module MOM_coms_infra public :: PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs +public :: any_across_PEs, all_across_PEs public :: field_chksum, MOM_infra_init, MOM_infra_end ! This module provides interfaces to the non-domain-oriented communication @@ -438,6 +439,36 @@ subroutine min_across_PEs_real_1d(field, length, pelist) call mpp_min(field, length, pelist) end subroutine min_across_PEs_real_1d +!> Implementation of any() intrinsic across PEs +function any_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: any_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call max_across_PEs(field_flag, pelist) + any_across_PEs = (field_flag > 0) +end function any_across_PEs + +!> Implementation of all() intrinsic across PEs +function all_across_PEs(field, pelist) + logical, intent(in) :: field !< Local PE value + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + logical :: all_across_PEs + + integer :: field_flag + + ! FMS1 does not support logical collectives, so integer flags are used. + field_flag = 0 + if (field) field_flag = 1 + call min_across_PEs(field_flag, pelist) + all_across_PEs = (field_flag > 0) +end function all_across_PEs + !> Initialize the model framework, including PE communication over a designated communicator. !! If no communicator ID is provided, the framework's default communicator is used. subroutine MOM_infra_init(localcomm) diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index c588628cbc..18ccdaae67 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -72,36 +72,36 @@ module MOM_diag_manager_infra !> Initialize a diagnostic axis integer function MOM_diag_axis_init(name, data, units, cart_name, long_name, MOM_domain, position, & & direction, edges, set_name, coarsen, null_axis) - character(len=*), intent(in) :: name !< The name of this axis - real, dimension(:), intent(in) :: data !< The array of coordinate values - character(len=*), intent(in) :: units !< The units for the axis data - character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) - character(len=*), & - optional, intent(in) :: long_name !< The long name of this axis - type(MOM_domain_type), & - optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition - integer, optional, intent(in) :: position !< This indicates the relative position of this - !! axis. The default is CENTER, but EAST and NORTH - !! are common options. - integer, optional, intent(in) :: direction !< This indicates the direction along which this - !! axis increases: 1 for upward, -1 for downward, or - !! 0 for non-vertical axes (the default) - integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that - !! describes the edges of this axis - character(len=*), & - optional, intent(in) :: set_name !< A name to use for this set of axes. - integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 - !! by default. - logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis - !! id for use with scalars. - - integer :: coarsening ! The degree of grid coarsening - - if (present(null_axis)) then ; if (null_axis) then - ! Return the special null axis id for scalars - MOM_diag_axis_init = null_axis_id - return - endif ; endif + character(len=*), intent(in) :: name !< The name of this axis + real, dimension(:), intent(in) :: data !< The array of coordinate values + character(len=*), intent(in) :: units !< The units for the axis data + character(len=*), intent(in) :: cart_name !< Cartesian axis ("X", "Y", "Z", "T", or "N" for none) + character(len=*), & + optional, intent(in) :: long_name !< The long name of this axis + type(MOM_domain_type), & + optional, intent(in) :: MOM_Domain !< A MOM_Domain that describes the decomposition + integer, optional, intent(in) :: position !< This indicates the relative position of this + !! axis. The default is CENTER, but EAST and NORTH + !! are common options. + integer, optional, intent(in) :: direction !< This indicates the direction along which this + !! axis increases: 1 for upward, -1 for downward, or + !! 0 for non-vertical axes (the default) + integer, optional, intent(in) :: edges !< The axis_id of the complementary axis that + !! describes the edges of this axis + character(len=*), & + optional, intent(in) :: set_name !< A name to use for this set of axes. + integer, optional, intent(in) :: coarsen !< An optional degree of coarsening for the grid, 1 + !! by default. + logical, optional, intent(in) :: null_axis !< If present and true, return the special null axis + !! id for use with scalars. + + integer :: coarsening ! The degree of grid coarsening + + if (present(null_axis)) then ; if (null_axis) then + ! Return the special null axis id for scalars + MOM_diag_axis_init = null_axis_id + return + endif ; endif if (present(MOM_domain)) then coarsening = 1 ; if (present(coarsen)) coarsening = coarsen diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index 5f8d5fb20b..d845d7317b 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -27,7 +27,7 @@ module MOM_domain_infra use fms_affinity_mod, only : fms_affinity_init, fms_affinity_set, fms_affinity_get ! This subroutine is not in MOM6/src but may be required by legacy drivers -use mpp_domains_mod, only : global_field_sum => mpp_global_sum +! use mpp_domains_mod, only : global_field_sum => mpp_global_sum ! The `group_pass_type` fields are never accessed, so we keep it as an FMS type use mpp_domains_mod, only : group_pass_type => mpp_group_update_type @@ -45,13 +45,13 @@ module MOM_domain_infra public :: redistribute_array, broadcast_domain, same_domain, global_field public :: get_simple_array_i_ind, get_simple_array_j_ind public :: MOM_thread_affinity_set, set_MOM_thread_affinity -! These are encoding constant parmeters. +! These are encoding constant parmeters with self-explanatory names. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners public :: AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR public :: CORNER, CENTER, NORTH_FACE, EAST_FACE ! These are no longer used by MOM6 because the reproducing sum works so well, but they are ! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM +! public :: global_field_sum, BITWISE_EXACT_SUM !> Do a halo update on an array interface pass_var @@ -1905,14 +1905,14 @@ end subroutine get_simple_array_j_ind !> Invert the contents of a 1-d array subroutine invert(array) - integer, dimension(:), intent(inout) :: array !< The 1-d array to invert - integer :: i, ni, swap - ni = size(array) - do i=1,ni - swap = array(i) - array(i) = array(ni+1-i) - array(ni+1-i) = swap - enddo + integer, dimension(:), intent(inout) :: array !< The 1-d array to invert + integer :: i, ni, swap + ni = size(array) + do i=1,ni + swap = array(i) + array(i) = array(ni+1-i) + array(ni+1-i) = swap + enddo end subroutine invert !> Returns the global shape of h-point arrays diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index b02beca313..c29459aad1 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -14,8 +14,8 @@ module MOM_interp_infra implicit none ; private -public :: horiz_interp_type, horiz_interp_init -public :: time_interp_extern, init_extern_field, time_interp_external_init +public :: horiz_interp_type, horizontal_interp_init +public :: time_interp_extern, init_extern_field, time_interp_extern_init public :: get_external_field_info, axistype, get_axis_data public :: run_horiz_interp, build_horiz_interp_weights @@ -39,6 +39,16 @@ module MOM_interp_infra contains +!> Do any initialization for the horizontal interpolation +subroutine horizontal_interp_init() + call horiz_interp_init() +end subroutine horizontal_interp_init + +!> Do any initialization for the time and space interpolation infrastructure +subroutine time_interp_extern_init() + call time_interp_external_init() +end subroutine time_interp_extern_init + !> perform horizontal interpolation of a 2d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, mask_in, mask_out, & @@ -61,7 +71,6 @@ subroutine horiz_interp_from_weights_field2d(Interp, data_in, data_out, verbose, end subroutine horiz_interp_from_weights_field2d - !> perform horizontal interpolation of a 3d field using pre-computed weights !! source and destination coordinates are 2d subroutine horiz_interp_from_weights_field3d(Interp, data_in, data_out, verbose, mask_in, mask_out, & diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 62a43ab99b..eb616dffa3 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -607,13 +607,16 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) !! is a fatal error if the field is not found. logical, optional, intent(in) :: no_domain !< If present and true, do not check for file !! names with an appended tile number - ! Local variables type(FmsNetcdfFile_t) :: fileobj_read ! A handle to a non-domain-decomposed file for obtaining information - ! about the exiting time axis entries in append mode. + ! about the exiting time axis entries in append mode. logical :: success ! If true, the file was opened successfully logical :: field_exists ! True if filename exists and field_name is in filename integer :: i, ndims + character(len=512), allocatable :: dimnames(:) ! Field dimension names + logical, allocatable :: is_x(:), is_y(:), is_t(:) ! True if index matches axis type + integer :: size_indices(4) ! Mapping of size index to FMS1 convention + integer :: idx, swap if (FMS2_reads) then field_exists = .false. @@ -626,7 +629,54 @@ subroutine get_field_size(filename, fieldname, sizes, field_found, no_domain) if (ndims > size(sizes)) call MOM_error(FATAL, & "get_field_size called with too few sizes for "//trim(fieldname)//" in "//trim(filename)) call get_variable_size(fileobj_read, fieldname, sizes(1:ndims)) + do i=ndims+1,size(sizes) ; sizes(i) = 0 ; enddo + + ! If sizes exceeds ndims, then we fallback to the FMS1 convention + ! where sizes has at least 4 dimension, and try to position values. + if (size(sizes) > ndims) then + ! Assume FMS1 positioning rules: (nx, ny, nz, nt, ...) + if (size(sizes) < 4) & + call MOM_error(FATAL, "If sizes(:) exceeds field dimensions, "& + &"then its length must be at least 4.") + + ! Fall back to the FMS1 default values of 1 (from mpp field%size) + sizes(ndims+1:) = 1 + + ! Gather the field dimension names + allocate(dimnames(ndims)) + dimnames(:) = "" + call get_variable_dimension_names(fileObj_read, trim(fieldname), & + dimnames) + + ! Test the dimensions against standard (x,y,t) names and attributes + allocate(is_x(ndims), is_y(ndims), is_t(ndims)) + is_x(:) = .false. + is_y(:) = .false. + is_t(:) = .false. + call categorize_axes(fileObj_read, filename, ndims, dimnames, & + is_x, is_y, is_t) + + ! Currently no z-test is supported, so disable assignment with 0 + size_indices = [ & + findloc(is_x, .true.), & + findloc(is_y, .true.), & + 0, & + findloc(is_t, .true.) & + ] + + do i = 1, size(size_indices) + idx = size_indices(i) + if (idx > 0) then + swap = sizes(i) + sizes(i) = sizes(idx) + sizes(idx) = swap + endif + enddo + + deallocate(is_x, is_y, is_t) + deallocate(dimnames) + endif endif endif endif @@ -1477,7 +1527,7 @@ end subroutine MOM_register_variable_axes !> Determine whether a variable's axes are associated with x-, y- or time-dimensions. Other !! unlimited dimensions are also labeled as time axes for these purposes. subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t) - type(FmsNetcdfDomainFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object + class(FmsNetcdfFile_t), intent(in) :: fileObj !< Handle to an open FMS2 netCDF file object character(len=*), intent(in) :: filename !< The name of the file to read integer, intent(in) :: ndims !< The number of dimensions associated with a variable character(len=*), dimension(ndims), intent(in) :: dim_names !< Names of the dimensions associated with a variable @@ -1524,8 +1574,10 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if (.not.(x_found .and. y_found)) then ! Look for hints from CF-compliant axis units for uncharacterized axes do i=1,ndims ; if (.not.(is_x(i) .or. is_y(i) .or. is_t(i))) then - call get_variable_units(fileobj, trim(dim_names(i)), units) - call categorize_axis_from_units(units, is_x(i), is_y(i)) + if (variable_exists(fileobj, trim(dim_names(i)))) then + call get_variable_units(fileobj, trim(dim_names(i)), units) + call categorize_axis_from_units(units, is_x(i), is_y(i)) + endif if (is_x(i)) x_found = .true. if (is_y(i)) y_found = .true. endif ; enddo diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 72afad16df..9e51d2873c 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -10,7 +10,7 @@ module MOM_ALE ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : check_column_integrals +use MOM_debugging, only : check_column_integrals, hchksum, uvchksum use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl use MOM_diag_mediator, only : time_type, diag_update_remap_grids use MOM_diag_vkernels, only : interpolate_column, reintegrate_column @@ -20,22 +20,23 @@ module MOM_ALE use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_hybgen_unmix, only : hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix, hybgen_unmix_CS +use MOM_hybgen_regrid, only : hybgen_regrid_CS use MOM_file_parser, only : get_param, param_file_type, log_param -use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE -use MOM_io, only : create_file, write_field, close_file, file_type use MOM_interface_heights,only : find_eta use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding use MOM_regridding, only : uniformResolution use MOM_regridding, only : inflate_vanished_layers_old +use MOM_regridding, only : regridding_preadjust_reqs, convective_adjustment use MOM_regridding, only : set_target_densities_from_GV, set_target_densities use MOM_regridding, only : regriddingCoordinateModeDoc, DEFAULT_COORDINATE_MODE use MOM_regridding, only : regriddingInterpSchemeDoc, regriddingDefaultInterpScheme use MOM_regridding, only : regriddingDefaultBoundaryExtrapolation use MOM_regridding, only : regriddingDefaultMinThickness -use MOM_regridding, only : regridding_CS, set_regrid_params -use MOM_regridding, only : getCoordinateInterfaces, getCoordinateResolution +use MOM_regridding, only : regridding_CS, set_regrid_params, write_regrid_file +use MOM_regridding, only : getCoordinateInterfaces use MOM_regridding, only : getCoordinateUnits, getCoordinateShortName use MOM_regridding, only : getStaticThickness use MOM_remapping, only : initialize_remapping, end_remapping @@ -64,14 +65,31 @@ module MOM_ALE logical :: remap_uv_using_old_alg !< If true, uses the old "remapping via a delta z" !! method. If False, uses the new method that !! remaps between grids described by h. + logical :: partial_cell_vel_remap !< If true, use partial cell thicknesses at velocity points + !! that are masked out where they extend below the shallower + !! of the neighboring bathymetry for remapping velocity. real :: regrid_time_scale !< The time-scale used in blending between the current (old) grid !! and the target (new) grid [T ~> s] type(regridding_CS) :: regridCS !< Regridding parameters and work arrays type(remapping_CS) :: remapCS !< Remapping parameters and work arrays + type(remapping_CS) :: vel_remapCS !< Remapping parameters for velocities and work arrays + + type(hybgen_unmix_CS), pointer :: hybgen_unmixCS => NULL() !< Parameters for hybgen remapping + + logical :: use_hybgen_unmix !< If true, use the hybgen unmixing code before regridding + logical :: do_conv_adj !< If true, do convective adjustment before regridding integer :: nk !< Used only for queries, not directly by this module + real :: BBL_h_vel_mask !< The thickness of a bottom boundary layer within which velocities in + !! thin layers are zeroed out after remapping, following practice with + !! Hybgen remapping, or a negative value to avoid such filtering + !! altogether, in [H ~> m or kg m-2]. + real :: h_vel_mask !< A thickness at velocity points below which near-bottom layers are + !! zeroed out after remapping, following the practice with Hybgen + !! remapping, or a negative value to avoid such filtering altogether, + !! in [H ~> m or kg m-2]. logical :: remap_after_initialization !< Indicates whether to regrid/remap after initializing the state. @@ -79,6 +97,7 @@ module MOM_ALE !! that recover the answers from the end of 2018. Otherwise, use more !! robust and accurate forms of mathematically equivalent expressions. + logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: show_call_tree !< For debugging ! for diagnostics @@ -108,7 +127,6 @@ module MOM_ALE public ALE_main_offline public ALE_offline_inputs public ALE_offline_tracer_final -public ALE_build_grid public ALE_regrid_accelerated public ALE_remap_scalar public ALE_PLM_edge_values @@ -144,16 +162,17 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) type(ALE_CS), pointer :: CS !< Module control structure ! Local variables - real, dimension(:), allocatable :: dz - character(len=40) :: mdl = "MOM_ALE" ! This module's name. - character(len=80) :: string ! Temporary strings - real :: filter_shallow_depth, filter_deep_depth - logical :: default_2018_answers - logical :: check_reconstruction - logical :: check_remapping - logical :: force_bounds_in_subcell - logical :: local_logical - logical :: remap_boundary_extrap + character(len=40) :: mdl = "MOM_ALE" ! This module's name. + character(len=80) :: string, vel_string ! Temporary strings + real :: filter_shallow_depth, filter_deep_depth + logical :: default_2018_answers + logical :: check_reconstruction + logical :: check_remapping + logical :: force_bounds_in_subcell + logical :: local_logical + logical :: remap_boundary_extrap + type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding + ! for sharing parameters. if (associated(CS)) then call MOM_error(WARNING, "ALE_init called with an associated "// & @@ -173,13 +192,19 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) ! Initialize and configure regridding call ALE_initRegridding(GV, US, max_depth, param_file, mdl, CS%regridCS) + call regridding_preadjust_reqs(CS%regridCS, CS%do_conv_adj, CS%use_hybgen_unmix, hybgen_CS=hybgen_regridCS) - ! Initialize and configure remapping + ! Initialize and configure remapping that is orchestrated by ALE. call get_param(param_file, mdl, "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) + call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & + "This sets the reconstruction scheme used for vertical remapping "//& + "of velocities. By default it is the same as REMAPPING_SCHEME. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=trim(string)) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& "consistency and if non-monotonicity or an inconsistency is "//& @@ -208,6 +233,17 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & answers_2018=CS%answers_2018) + call initialize_remapping( CS%vel_remapCS, vel_string, & + boundary_extrapolation=remap_boundary_extrap, & + check_reconstruction=check_reconstruction, & + check_remapping=check_remapping, & + force_bounds_in_subcell=force_bounds_in_subcell, & + answers_2018=CS%answers_2018) + + call get_param(param_file, mdl, "PARTIAL_CELL_VELOCITY_REMAP", CS%partial_cell_vel_remap, & + "If true, use partial cell thicknesses at velocity points that are masked out "//& + "where they extend below the shallower of the neighboring bathymetry for "//& + "remapping velocity.", default=.false.) call get_param(param_file, mdl, "REMAP_AFTER_INITIALIZATION", CS%remap_after_initialization, & "If true, applies regridding and remapping immediately after "//& @@ -239,6 +275,24 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) "code.", default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) + call get_param(param_file, mdl, "REMAP_VEL_MASK_BBL_THICK", CS%BBL_h_vel_mask, & + "A thickness of a bottom boundary layer below which velocities in thin layers "//& + "are zeroed out after remapping, following practice with Hybgen remapping, "//& + "or a negative value to avoid such filtering altogether.", & + default=-0.001, units="m", scale=GV%m_to_H) + call get_param(param_file, mdl, "REMAP_VEL_MASK_H_THIN", CS%h_vel_mask, & + "A thickness at velocity points below which near-bottom layers are zeroed out "//& + "after remapping, following practice with Hybgen remapping, or a negative value "//& + "to avoid such filtering altogether.", & + default=1.0e-6, units="m", scale=GV%m_to_H, do_not_log=(CS%BBL_h_vel_mask<=0.0)) + + if (CS%use_hybgen_unmix) & + call init_hybgen_unmix(CS%hybgen_unmixCS, GV, US, param_file, hybgen_regridCS) + + call get_param(param_file, "MOM", "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + ! Keep a record of values for subsequent queries CS%nk = GV%ke @@ -279,7 +333,7 @@ subroutine ALE_register_diags(Time, G, GV, US, diag, CS) 'm', conversion=GV%H_to_m, v_extensive=.true.) cs%id_vert_remap_h_tendency = register_diag_field('ocean_model','vert_remap_h_tendency',diag%axestl,time, & 'Layer thicknesses tendency due to ALE regridding and remapping', & - 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive = .true.) + 'm s-1', conversion=GV%H_to_m*US%s_to_T, v_extensive=.true.) end subroutine ALE_register_diags @@ -289,7 +343,7 @@ end subroutine ALE_register_diags !! We read the MOM_input file to register the values of different !! regridding/remapping parameters. subroutine adjustGridForIntegrity( CS, G, GV, h ) - type(ALE_CS), pointer :: CS !< Regridding parameters and options + type(ALE_CS), intent(in) :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in) :: G !< Ocean grid informations type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Current 3D grid thickness that @@ -307,6 +361,8 @@ subroutine ALE_end(CS) ! Deallocate memory used for the regridding call end_remapping( CS%remapCS ) + + if (CS%use_hybgen_unmix) call end_hybgen_unmix( CS%hybgen_unmixCS ) call end_regridding( CS%regridCS ) deallocate(CS) @@ -335,12 +391,10 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta_preale real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec - logical :: ice_shelf - - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) !< If true, PCM remapping should be used in a cell. + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - ice_shelf = present(frac_shelf_h) + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main(), MOM_ALE.F90") @@ -360,13 +414,19 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) endif dzRegrid(:,:,:) = 0.0 + ! If necessary, do some preparatory work to clean up the model state before regridding. + + ! This adjusts the input thicknesses prior to remapping, based on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. - if (ice_shelf) then - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h) - else - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) - endif + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) call check_grid( G, GV, h, 0. ) @@ -377,23 +437,30 @@ subroutine ALE_main( G, GV, US, h, u, v, tv, Reg, CS, OBC, dt, frac_shelf_h) if (present(dt)) then call diag_update_remap_grids(CS%diag) endif + ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, dzRegrid, & - u, v, CS%show_call_tree, dt ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, dzRegrid, u, v, & + CS%show_call_tree, dt, PCM_cell=PCM_cell ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. !$OMP parallel do default(shared) - do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + do k=1,nk ; do j=jsc-1,jec+1 ; do i=isc-1,iec+1 h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - if (CS%show_call_tree) call callTree_leave("ALE_main()") + if (CS%debug) then + call hchksum(h, "Post-ALE_main h", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(tv%T, "Post-ALE_main T", G%HI, haloshift=0) + call hchksum(tv%S, "Post-ALE_main S", G%HI, haloshift=0) + call uvchksum("Post-ALE_main [uv]", u, v, G%HI, haloshift=0, scale=US%L_T_to_m_s) + endif if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) + if (CS%show_call_tree) call callTree_leave("ALE_main()") end subroutine ALE_main @@ -414,9 +481,9 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_new ! New 3D grid obtained after last time step [H ~> m or kg m-2] - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_main_offline(), MOM_ALE.F90") @@ -425,9 +492,16 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) endif dzRegrid(:,:,:) = 0.0 + ! This adjusts the input state prior to remapping, depending on the verical coordinate. + if (CS%do_conv_adj) call convective_adjustment(G, GV, h, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + ! Build new grid. The new grid is stored in h_new. The old grid is h. ! Both are needed for the subsequent remapping of variables. - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid ) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h, 0. ) @@ -435,8 +509,7 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, OBC, dt) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars(CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, & - debug=CS%show_call_tree, dt=dt ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree, dt=dt ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_main)") @@ -475,7 +548,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) real, dimension(SZK_(GV)) :: h_dest ! Destination grid thicknesses at velocity points [H ~> m or kg m-2] real, dimension(SZK_(GV)) :: temp_vec ! Transports on the destination grid [H L2 ~> m3 or kg] - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke dzRegrid(:,:,:) = 0.0 h_new(:,:,:) = 0.0 @@ -484,12 +557,12 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective ! adjustment right now is not used because it is unclear what to do with vanished layers - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust = .false. ) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h_new, 0. ) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -551,13 +624,18 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid !< The change in grid interface positions real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new !< Regridded target thicknesses - integer :: nk, i, j, k, isc, iec, jsc, jec + integer :: ntr, i, j, k, isc, iec, jsc, jec, nk - nk = GV%ke; isc = G%isc; iec = G%iec; jsc = G%jsc; jec = G%jec + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke if (CS%show_call_tree) call callTree_enter("ALE_offline_tracer_final(), MOM_ALE.F90") ! Need to make sure that h_target is consistent with the current offline ALE confiuration - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid ) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_target, tv) + if (CS%use_hybgen_unmix) then + ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr + call hybgen_unmix(G, GV, G%US, CS%hybgen_unmixCS, tv, Reg, ntr, h) + endif + call regridding_main( CS%remapCS, CS%regridCS, G, GV, h_target, tv, h_new, dzRegrid, conv_adjust=.false. ) call check_grid( G, GV, h_target, 0. ) @@ -565,7 +643,7 @@ subroutine ALE_offline_tracer_final( G, GV, h, tv, h_target, Reg, CS, OBC) ! Remap all variables from old grid h onto new grid h_new - call remap_all_state_vars( CS%remapCS, CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) + call remap_all_state_vars( CS, G, GV, h, h_new, Reg, OBC, debug=CS%show_call_tree ) if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_offline_tracer_final)") @@ -607,56 +685,17 @@ subroutine check_grid( G, GV, h, threshold ) end subroutine check_grid -!> Generates new grid -subroutine ALE_build_grid( G, GV, regridCS, remapCS, h, tv, debug, frac_shelf_h ) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(regridding_CS), intent(in) :: regridCS !< Regridding parameters and options - type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variable structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Current 3D grid obtained after the - !! last time step [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in):: frac_shelf_h !< Fractional ice shelf coverage [nondim] - ! Local variables - integer :: nk, i, j, k - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)+1) :: dzRegrid ! The change in grid interface positions - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: h_new ! The new grid thicknesses - logical :: show_call_tree, use_ice_shelf - - show_call_tree = .false. - if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("ALE_build_grid(), MOM_ALE.F90") - use_ice_shelf = present(frac_shelf_h) - - ! Build new grid. The new grid is stored in h_new. The old grid is h. - ! Both are needed for the subsequent remapping of variables. - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid, frac_shelf_h ) - else - call regridding_main( remapCS, regridCS, G, GV, h, tv, h_new, dzRegrid ) - endif - - ! Override old grid with new one. The new grid 'h_new' is built in - ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(G,h,h_new) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) h(i,j,:) = h_new(i,j,:) - enddo ; enddo - - if (show_call_tree) call callTree_leave("ALE_build_grid()") -end subroutine ALE_build_grid !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) - integer, intent(in) :: n !< Number of times to regrid + integer, intent(in) :: n_itt !< Number of times to regrid real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -671,7 +710,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg !! routine (and expect diagnostics to work) ! Local variables - integer :: i, j, k, nz + integer :: i, j, itt, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses @@ -679,6 +718,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface, dzIntTotal + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] nz = GV%ke @@ -704,17 +744,30 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg if (present(dt)) & call ALE_update_regrid_weights(dt, CS) - do k = 1, n + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + + + do itt = 1, n_itt + call do_group_pass(pass_T_S_h, G%domain) ! generate new grid - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) + if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface, conv_adjust=.false.) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:)) - call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:)) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%S(i,j,:), nz, h(i,j,:), tv_local%S(i,j,:), & + h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, nz, h_orig(i,j,:), tv%T(i,j,:), nz, h(i,j,:), tv_local%T(i,j,:), & + h_neglect, h_neglect_edge) enddo ; enddo ! starting grid for next iteration @@ -722,7 +775,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, OBC, Reg, dt, dzReg enddo ! remap all state variables (including those that weren't needed for regridding) - call remap_all_state_vars(CS%remapCS, CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) + call remap_all_state_vars(CS, G, GV, h_orig, h, Reg, OBC, dzIntTotal, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -734,10 +787,9 @@ end subroutine ALE_regrid_accelerated !! This routine is called during initialization of the model at time=0, to !! remap initial conditions to the model grid. It is also called during a !! time step to update the state. -subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, OBC, & - dzInterface, u, v, debug, dt) - type(remapping_CS), intent(in) :: CS_remapping !< Remapping control structure - type(ALE_CS), intent(in) :: CS_ALE !< ALE control structure +subroutine remap_all_state_vars(CS, G, GV, h_old, h_new, Reg, OBC, & + dzInterface, u, v, debug, dt, PCM_cell) + type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid @@ -755,38 +807,45 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, optional, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] logical, optional, intent(in) :: debug !< If true, show the call tree real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] real, dimension(GV%ke+1) :: dz ! The change in interface heights interpolated to ! a velocity point [H ~> m or kg m-2] - real, dimension(GV%ke) :: h1 ! A column of initial thicknesses [H ~> m or kg m-2] - real, dimension(GV%ke) :: h2 ! A column of updated thicknesses [H ~> m or kg m-2] - real, dimension(GV%ke) :: u_column ! A column of properties, like tracer concentrations - ! or velocities, being remapped [various units] - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer - ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or - ! cell thickness [H T-1 ~> m s-1 or Conc kg m-2 s-1] - real, dimension(SZI_(G), SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer - ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] - real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: tr_column(GV%ke) ! A column of updated tracer concentrations + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_conc ! The rate of change of concentrations [Conc T-1 ~> Conc s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_cont ! The rate of change of cell-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] or + ! cell thickness [H T-1 ~> m s-1 or Conc kg m-2 s-1] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! The rate of change of column-integrated tracer + ! content [Conc H T-1 ~> Conc m s-1 or Conc kg m-2 s-1] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] + real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] + real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] + real :: v_tgt(GV%ke) ! A column of v-velocities on the target grid [L T-1 ~> m s-1] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] - logical :: show_call_tree - type(tracer_type), pointer :: Tr => NULL() + logical :: show_call_tree + type(tracer_type), pointer :: Tr => NULL() integer :: i, j, k, m, nz, ntr show_call_tree = .false. if (present(debug)) show_call_tree = debug - if (show_call_tree) call callTree_enter("remap_all_state_vars(), MOM_ALE.F90") ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dzInterface. Otherwise, ! u and v can be remapped without dzInterface - if ( .not. present(dzInterface) .and. (CS_ALE%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then + if ( .not. present(dzInterface) .and. (CS%remap_uv_using_old_alg .and. (present(u) .or. present(v))) ) then call MOM_error(FATAL, "remap_all_state_vars: dzInterface must be present if using old algorithm "// & "and u/v are to be remapped") endif - if (.not.CS_ALE%answers_2018) then + if (.not.CS%answers_2018) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 @@ -794,7 +853,9 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 endif - nz = GV%ke + if (show_call_tree) call callTree_enter("remap_all_state_vars(), MOM_ALE.F90") + + nz = GV%ke ntr = 0 ; if (associated(Reg)) ntr = Reg%ntr @@ -804,43 +865,49 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_cont(:,:,:) = 0.0 endif - ! Remap tracer + ! Remap all registered tracers, including temperature and salinity. if (ntr>0) then if (show_call_tree) call callTree_waypoint("remapping tracers (remap_all_state_vars)") - !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) + !$OMP parallel do default(shared) private(h1,h2,tr_column,Tr,PCM,work_conc,work_cont,work_2d) do m=1,ntr ! For each tracer Tr => Reg%Tr(m) do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then ! Build the start and final grids h1(:) = h_old(i,j,:) h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) + if (present(PCM_cell)) then + PCM(:) = PCM_cell(i,j,:) + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge, PCM_cell=PCM) + else + call remapping_core_h(CS%remapCS, nz, h1, Tr%t(i,j,:), nz, h2, tr_column, & + h_neglect, h_neglect_edge) + endif ! Intermediate steps for tendency of tracer concentration and tracer content. if (present(dt)) then if (Tr%id_remap_conc > 0) then do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k)) * Idt + work_conc(i,j,k) = (tr_column(k) - Tr%t(i,j,k)) * Idt enddo endif if (Tr%id_remap_cont > 0 .or. Tr%id_remap_cont_2d > 0) then do k=1,GV%ke - work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + work_cont(i,j,k) = (tr_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt enddo endif endif ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + Tr%t(i,j,:) = tr_column(:) endif ; enddo ; enddo ! tendency diagnostics. if (present(dt)) then if (Tr%id_remap_conc > 0) then - call post_data(Tr%id_remap_conc, work_conc, CS_ALE%diag) + call post_data(Tr%id_remap_conc, work_conc, CS%diag) endif if (Tr%id_remap_cont > 0) then - call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) + call post_data(Tr%id_remap_cont, work_cont, CS%diag) endif if (Tr%id_remap_cont_2d > 0) then do j = G%jsc,G%jec ; do i = G%isc,G%iec @@ -849,43 +916,65 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo enddo ; enddo - call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) + call post_data(Tr%id_remap_cont_2d, work_2d, CS%diag) endif endif enddo ! m=1,ntr - endif ! endif for ntr > 0 + endif ! endif for ntr > 0 if (show_call_tree) call callTree_waypoint("tracers remapped (remap_all_state_vars)") + if (CS%partial_cell_vel_remap .and. (present(u) .or. present(v)) ) then + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_old(i,j,k) + enddo ; enddo ; enddo + endif + ! Remap u velocity component if ( present(u) ) then - !$OMP parallel do default(shared) private(h1,h2,dz,u_column) - do j = G%jsc,G%jec ; do I = G%iscB,G%iecB ; if (G%mask2dCu(I,j)>0.) then + + !$OMP parallel do default(shared) private(h1,h2,dz,u_src,h_mask_vel,u_tgt) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) - if (CS_ALE%remap_uv_using_old_alg) then + do k=1,nz + u_src(k) = u(I,j,k) + h1(k) = 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + h2(k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + enddo + if (CS%remap_uv_using_old_alg) then dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i+1,j,:) ) do k = 1, nz h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) endif - if (associated(OBC)) then - if (OBC%segnum_u(I,j) /= 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - h1(:) = h_old(i+1,j,:) - h2(:) = h_new(i+1,j,:) - endif + + if (CS%partial_cell_vel_remap) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h1, h_mask_vel) + call apply_partial_cell_mask(h2, h_mask_vel) + endif + + if (associated(OBC)) then ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + do k=1,nz ; h1(k) = h_old(i+1,j,k) ; h2(k) = h_new(i+1,j,k) ; enddo endif + endif ; endif + + ! --- Remap u profiles from the source vertical grid onto the new target grid. + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - u(I,j,:) = u_column(:) + + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k endif ; enddo ; enddo endif @@ -893,41 +982,53 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then - !$OMP parallel do default(shared) private(h1,h2,dz,u_column) - do J = G%jscB,G%jecB ; do i = G%isc,G%iec ; if (G%mask2dCv(i,j)>0.) then + !$OMP parallel do default(shared) private(h1,h2,v_src,dz,h_mask_vel,v_tgt) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) - if (CS_ALE%remap_uv_using_old_alg) then + do k=1,nz + v_src(k) = v(i,J,k) + h1(k) = 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + h2(k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + enddo + if (CS%remap_uv_using_old_alg) then dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i,j+1,:) ) do k = 1, nz h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) endif - if (associated(OBC)) then - if (OBC%segnum_v(i,J) /= 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - h1(:) = h_old(i,j+1,:) - h2(:) = h_new(i,j+1,:) - endif + if (CS%partial_cell_vel_remap) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h1, h_mask_vel) + call apply_partial_cell_mask(h2, h_mask_vel) + endif + if (associated(OBC)) then ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + do k=1,nz ; h1(k) = h_old(i,j+1,k) ; h2(k) = h_new(i,j+1,k) ; enddo endif + endif ; endif + + ! --- Remap v profiles from the source vertical grid onto the new target grid. + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & + h_neglect, h_neglect_edge) + + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - v(i,J,:) = u_column(:) + + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k endif ; enddo ; enddo endif - if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) - if ((CS_ALE%id_vert_remap_h_tendency > 0) .and. present(dt)) then + if (CS%id_vert_remap_h > 0) call post_data(CS%id_vert_remap_h, h_old, CS%diag) + if ((CS%id_vert_remap_h_tendency > 0) .and. present(dt)) then do k = 1, nz ; do j = G%jsc,G%jec ; do i = G%isc,G%iec work_cont(i,j,k) = (h_new(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo - call post_data(CS_ALE%id_vert_remap_h_tendency, work_cont, CS_ALE%diag) + call post_data(CS%id_vert_remap_h_tendency, work_cont, CS%diag) endif if (show_call_tree) call callTree_waypoint("v remapped (remap_all_state_vars)") if (show_call_tree) call callTree_leave("remap_all_state_vars()") @@ -935,6 +1036,55 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, end subroutine remap_all_state_vars +!> Mask out thicknesses to 0 when their runing sum exceeds a specified value. +subroutine apply_partial_cell_mask(h1, h_mask) + real, dimension(:), intent(inout) :: h1 !< A column of thicknesses to be masked out after their + !! running vertical sum exceeds h_mask [H ~> m or kg m-2] + real, intent(in) :: h_mask !< The depth after which the thicknesses in h1 are + !! masked out [H ~> m or kg m-2] + ! Local variables + real :: h1_rsum ! The running sum of h1 [H ~> m or kg m-2] + integer :: k + + h1_rsum = 0.0 + do k=1,size(h1) + if (h1(k) > h_mask - h1_rsum) then + ! This thickness is reduced because it extends below the shallower neighboring bathymetry. + h1(k) = max(h_mask - h1_rsum, 0.0) + h1_rsum = h_mask + else + h1_rsum = h1_rsum + h1(k) + endif + enddo +end subroutine apply_partial_cell_mask + + +!> Zero out velocities in a column in very thin layers near the seafloor +subroutine mask_near_bottom_vel(vel, h, h_BBL, h_thin, nk) + integer, intent(in) :: nk !< The number of layers in this column + real, intent(inout) :: vel(nk) !< The velocity component being zeroed out [L T-1 ~> m s-1] + real, intent(in) :: h(nk) !< The layer thicknesses at velocity points [H ~> m or kg m-2] + real, intent(in) :: h_BBL !< The thickness of the near-bottom region over which to apply + !! the filtering [H ~> m or kg m-2] + real, intent(in) :: h_thin !< A layer thickness below which the filtering is applied [H ~> m or kg m-2] + + ! Local variables + real :: h_from_bot ! The distance between the top of a layer and the seafloor [H ~> m or kg m-2] + integer :: k + + if ((h_BBL < 0.0) .or. (h_thin < 0.0)) return + + h_from_bot = 0.0 + do k=nk,1,-1 + h_from_bot = h_from_bot + h(k) + if (h_from_bot > h_BBL) return + ! Set the velocity to zero in thin, near-bottom layers. + if (h(k) <= h_thin) vel(k) = 0.0 + enddo !k + +end subroutine mask_near_bottom_vel + + !> Remaps a single scalar between grids described by thicknesses h_src and h_dst. !! h_dst must be dimensioned as a model array with GV%ke layers while h_src can !! have an arbitrary number of layers specified by nk_src. @@ -1274,26 +1424,10 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=*), intent(in) :: directory !< directory for writing grid info character(len=240) :: filepath - type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - type(file_type) :: IO_handle ! The I/O handle of the fileset - real :: ds(GV%ke), dsi(GV%ke+1) - - filepath = trim(directory) // trim("Vertical_coordinate") - ds(:) = getCoordinateResolution( CS%regridCS, undo_scaling=.true. ) - dsi(1) = 0.5*ds(1) - dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) - dsi(GV%ke+1) = 0.5*ds(GV%ke) - - vars(1) = var_desc('ds', getCoordinateUnits( CS%regridCS ), & - 'Layer Coordinate Thickness','1','L','1') - vars(2) = var_desc('ds_interface', getCoordinateUnits( CS%regridCS ), & - 'Layer Center Coordinate Separation','1','i','1') - - call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) - call write_field(IO_handle, fields(1), ds) - call write_field(IO_handle, fields(2), dsi) - call close_file(IO_handle) + + filepath = trim(directory) // trim("Vertical_coordinate") + + call write_regrid_file(CS%regridCS, GV, filepath) end subroutine ALE_writeCoordinateFile @@ -1305,7 +1439,7 @@ subroutine ALE_initThicknessToCoord( CS, G, GV, h ) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: h !< layer thickness [H ~> m or kg m-2] ! Local variables - integer :: i, j, k + integer :: i, j do j = G%jsd,G%jed ; do i = G%isd,G%ied h(i,j,:) = GV%Z_to_H * getStaticThickness( CS%regridCS, 0., G%bathyT(i,j)+G%Z_ref ) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 new file mode 100644 index 0000000000..22fd474854 --- /dev/null +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -0,0 +1,978 @@ +!> This module contains the hybgen regridding routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_regrid + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE +use MOM_string_functions, only : slasher +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_regrid_CS ; private + + real :: min_thickness !< Minimum thickness allowed for layers [H ~> m or kg m-2] + + integer :: nk !< Number of layers on the target grid + + !> Reference pressure for density calculations [R L2 T-2 ~> Pa] + real :: ref_pressure + + !> Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + real :: hybiso + !> Number of sigma levels used by HYBGEN + integer :: nsigma + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Fractional relaxation within a regridding step [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to values in m + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to values in kg m-3 + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: thkbot !< Thickness of a bottom boundary layer, within which hybgen does + !! something different. [H ~> m or kg m-2] + + !> Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real :: topiso_const + ! real, dimension(:,:), allocatable :: topiso + + !> Nominal density of interfaces [R ~> kg m-3] + real, allocatable, dimension(:) :: target_density + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2] + +end type hybgen_regrid_CS + + +public hybgen_regrid, init_hybgen_regrid, end_hybgen_regrid +public hybgen_column_init, get_hybgen_regrid_params, write_Hybgen_coord_file + +contains + +!> Initialise a hybgen_regrid_CS control structure and store its parameters +subroutine init_hybgen_regrid(CS, GV, US, param_file) + type(hybgen_regrid_CS), pointer :: CS !< Unassociated pointer to hold the control 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 + + character(len=40) :: mdl = "MOM_hybgen_regrid" ! This module's name. + real :: hybrlx ! The number of remappings over which to move toward the target coordinate [timesteps] + character(len=40) :: dp0_coord_var, ds0_coord_var, rho_coord_var + character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + logical :: use_coord_file + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_regrid: CS already associated!") + allocate(CS) + + CS%nk = GV%ke + + allocate(CS%target_density(CS%nk)) + allocate(CS%dp0k(CS%nk), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(CS%nk), source=0.0) ! minimum shallow z-layer separation + + do k=1,CS%nk ; CS%target_density(k) = GV%Rlay(k) ; enddo + + call get_param(param_file, mdl, "P_REF", CS%ref_pressure, & + "The pressure that is used for calculating the coordinate "//& + "density. (1 Pa = 1e4 dbar, so 2e7 is commonly used.) "//& + "This is only used if USE_EOS and ENABLE_THERMODYNAMICS are true.", & + units="Pa", default=2.0e7, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) + + call get_param(param_file, mdl, "HYBGEN_MIN_THICKNESS", CS%min_thickness, & + "The minimum layer thickness allowed when regridding with Hybgen.", & + units="m", default=0.0, scale=GV%m_to_H ) + + call get_param(param_file, mdl, "HYBGEN_N_SIGMA", CS%nsigma, & + "The number of sigma-coordinate (terrain-following) layers with Hybgen regridding.", & + default=0) + call get_param(param_file, mdl, "HYBGEN_COORD_FILE", coord_file, & + "The file from which the Hybgen profile is read, or blank to use a list of "//& + "real input parameters from the MOM_input file.", default="") + + use_coord_file = (len_trim(coord_file) > 0) + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_PR0FILE", CS%dp0k, & + "The layerwise list of deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_PR0FILE", CS%ds0k, & + "The layerwise list of shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + units="m", default=0.0, scale=GV%m_to_H, do_not_log=use_coord_file) + + if (use_coord_file) then + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + filename = trim(inputdir)//trim(coord_file) + call log_param(param_file, mdl, "INPUTDIR/HYBGEN_COORD_FILE", filename) + if (.not.file_exists(filename)) call MOM_error(FATAL, & + " set_coord_from_file: Unable to open "//trim(filename)) + + call get_param(param_file, mdl, "HYBGEN_DEEP_DZ_VAR", dp0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "deep z-level minimum thicknesses for Hybgen (dp0k in Hycom).", & + default="dp0") + call get_param(param_file, mdl, "HYBGEN_SHALLOW_DZ_VAR", ds0_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the "//& + "shallow z-level minimum thicknesses for Hybgen (ds0k in Hycom).", & + default="ds0") + call get_param(param_file, mdl, "HYBGEN_TGT_DENSITY_VAR", rho_coord_var, & + "The variable in HYBGEN_COORD_FILE that is to be used for the Hybgen "//& + "target layer densities, or blank to reuse the values in GV%Rlay.", & + default="") + + call MOM_read_data(filename, dp0_coord_var, CS%dp0k, scale=GV%m_to_H) + + call MOM_read_data(filename, ds0_coord_var, CS%ds0k, scale=GV%m_to_H) + + if (len_trim(rho_coord_var) > 0) & + call MOM_read_data(filename, rho_coord_var, CS%target_density, scale=US%kg_m3_to_R) + endif + + call get_param(param_file, mdl, "HYBGEN_ISOPYCNAL_DZ_MIN", CS%dp00i, & + "The Hybgen deep isopycnal spacing minimum thickness (dp00i in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_MIN_ISO_DEPTH", CS%topiso_const, & + "The Hybgen shallowest depth for isopycnal layers (isotop in Hycom)", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_RELAX_PERIOD", hybrlx, & + "The Hybgen coordinate relaxation period in timesteps, or 1 to move to "//& + "the new target coordinates in a single step. This must be >= 1.", & + units="timesteps", default=1.0) + if (hybrlx < 1.0) call MOM_error(FATAL, "init_hybgen_regrid: HYBGEN_RELAX_PERIOD must be at least 1.") + CS%qhybrlx = 1.0 / hybrlx + call get_param(param_file, mdl, "HYBGEN_BBL_THICKNESS", CS%thkbot, & + "A bottom boundary layer thickness within which Hybgen is able to move "//& + "overlying layers upward to match a target density.", & + units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & + "A tolerance between the layer densities and their target, within which "//& + "Hybgen determines that remapping uses PCM for a layer.", & + units="kg m-3", default=0.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "HYBGEN_REMAP_MIN_ZSTAR_DILATE", CS%min_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=0.5) + call get_param(param_file, mdl, "HYBGEN_REMAP_MAX_ZSTAR_DILATE", CS%max_dilate, & + "The maximum amount of dilation that is permitted when converting target "//& + "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & + default=2.0) + + CS%onem = 1.0 * GV%m_to_H + + do k=1,CS%nk ; CS%dp0k(k) = max(CS%dp0k(k), CS%min_thickness) ; enddo + CS%dp00i = max(CS%dp00i, CS%min_thickness) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + + CS%coord_scale = GV%H_to_m + CS%Rho_coord_scale = US%R_to_kg_m3 + +end subroutine init_hybgen_regrid + +!> Writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model. +subroutine write_Hybgen_coord_file(GV, CS, filepath) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(hybgen_regrid_CS), intent(in) :: CS !< Control structure for this module + character(len=*), intent(in) :: filepath !< The full path to the file to write + ! Local variables + type(vardesc) :: vars(3) + type(fieldtype) :: fields(3) + type(file_type) :: IO_handle ! The I/O handle of the fileset + + vars(1) = var_desc("dp0", "meter", "Deep z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(2) = var_desc("ds0", "meter", "Shallow z-level minimum thicknesses for Hybgen", '1', 'L', '1') + vars(3) = var_desc("Rho_tgt", "kg m-3", "Target coordinate potential densities for Hybgen", '1', 'L', '1') + call create_file(IO_handle, trim(filepath), vars, 3, fields, SINGLE_FILE, GV=GV) + + call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) + call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) + + call close_file(IO_handle) + +end subroutine write_Hybgen_coord_file + +!> This subroutine deallocates memory in the control structure for the hybgen module +subroutine end_hybgen_regrid(CS) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_regrid + +!> This subroutine can be used to retrieve the parameters for the hybgen regrid module +subroutine get_hybgen_regrid_params(CS, nk, ref_pressure, hybiso, nsigma, dp00i, qhybrlx, & + dp0k, ds0k, dpns, dsns, min_dilate, max_dilate, & + thkbot, topiso_const, target_density) + type(hybgen_regrid_CS), pointer :: CS !< Coordinate regridding control structure + integer, optional, intent(out) :: nk !< Number of layers on the target grid + real, optional, intent(out) :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, optional, intent(out) :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + integer, optional, intent(out) :: nsigma !< Number of sigma levels used by HYBGEN + real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness (m) + real, optional, intent(out) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, optional, intent(out) :: dp0k(:) !< minimum deep z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: ds0k(:) !< minimum shallow z-layer separation [H ~> m or kg m-2] + real, optional, intent(out) :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real, optional, intent(out) :: min_dilate !< The minimum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when wetting occurs. + real, optional, intent(out) :: max_dilate !< The maximum amount of dilation that is permitted when + !! converting target coordinates from z to z* [nondim]. + !! This limit applies when drying occurs. + real, optional, intent(out) :: thkbot !< Thickness of a bottom boundary layer, within which + !! hybgen does something different. [H ~> m or kg m-2] + real, optional, intent(out) :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + real, optional, intent(out) :: target_density(:) !< Nominal density of interfaces [R ~> kg m-3] + + if (.not. associated(CS)) call MOM_error(FATAL, "get_hybgen_params: CS not associated") + + if (present(nk)) nk = CS%nk + if (present(ref_pressure)) ref_pressure = CS%ref_pressure + if (present(hybiso)) hybiso = CS%hybiso + if (present(nsigma)) nsigma = CS%nsigma + if (present(dp00i)) dp00i = CS%dp00i + if (present(qhybrlx)) qhybrlx = CS%qhybrlx + if (present(dp0k)) then + if (size(dp0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The dp0k argument is not allocated with enough space.") + dp0k(1:CS%nk) = CS%dp0k(1:CS%nk) + endif + if (present(ds0k)) then + if (size(ds0k) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The ds0k argument is not allocated with enough space.") + ds0k(1:CS%nk) = CS%ds0k(1:CS%nk) + endif + if (present(dpns)) dpns = CS%dpns + if (present(dsns)) dsns = CS%dsns + if (present(min_dilate)) min_dilate = CS%min_dilate + if (present(max_dilate)) max_dilate = CS%max_dilate + if (present(thkbot)) thkbot = CS%thkbot + if (present(topiso_const)) topiso_const = CS%topiso_const + if (present(target_density)) then + if (size(target_density) < CS%nk) call MOM_error(FATAL, "get_hybgen_regrid_params: "//& + "The target_density argument is not allocated with enough space.") + target_density(1:CS%nk) = CS%target_density(1:CS%nk) + endif + +end subroutine get_hybgen_regrid_params + + +!> Modify the input grid to give a new vertical grid based on the HYCOM hybgen code. +subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & + intent(inout) :: dzInterface !< The change in height of each interface, + !! using a sign convention opposite to the change + !! in pressure [H ~> m or kg m-2] + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(inout) :: PCM_cell !< If true, PCM remapping should be used in a cell. + !! This is effectively intent out, but values in wide + !! halo regions and land points are reused. + + ! --- ------------------------------------- + ! --- hybrid grid generator from HYCOM + ! --- ------------------------------------- + + ! These notes on the parameters for the hybrid grid generator are inhereted from the + ! Hycom source code for these algorithms. + ! + ! From blkdat.input (units may have changed from m to pressure): + ! + ! --- 'nsigma' = number of sigma levels + ! --- 'dp0k ' = layer k deep z-level spacing minimum thickness (m) + ! --- k=1,nk + ! --- 'ds0k ' = layer k shallow z-level spacing minimum thickness (m) + ! --- k=1,nsigma + ! --- 'dp00i' = deep isopycnal spacing minimum thickness (m) + ! --- 'isotop' = shallowest depth for isopycnal layers (m) + ! now in topiso(:,:) + ! --- 'sigma ' = isopycnal layer target densities (sigma units) + ! --- now in theta(:,:,1:nk) + ! + ! --- the above specifies a vertical coord. that is isopycnal or: + ! --- near surface z in deep water, based on dp0k + ! --- near surface z in shallow water, based on ds0k and nsigma + ! --- terrain-following between them, based on ds0k and nsigma + ! + ! --- terrain following starts at depth dpns=sum(dp0k(k),k=1,nsigma) and + ! --- ends at depth dsns=sum(ds0k(k),k=1,nsigma), and the depth of the + ! --- k-th layer interface varies linearly with total depth between + ! --- these two reference depths, i.e. a z-sigma-z fixed coordinate. + ! + ! --- near the surface (i.e. shallower than isotop), layers are always + ! --- fixed depth (z or sigma). + ! -- layer 1 is always fixed, so isotop=0.0 is not realizable. + ! --- near surface layers can also be forced to be fixed depth + ! --- by setting target densities (sigma(k)) very small. + ! + ! --- away from the surface, the minimum layer thickness is dp00i. + ! + ! --- for fixed depth targets to be: + ! --- z-only set nsigma=0, + ! --- sigma-z (shallow-deep) use a very small ds0k(:), + ! --- sigma-only set nsigma=nk, dp0k large, and ds0k small. + + ! These arrays work with the input column + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: temp_in(GV%ke) ! A column of input potential temperatures [degC] + real :: saln_in(GV%ke) ! A column of input layer salinities [ppt] + real :: Rcv_in(GV%ke) ! An input column of coordinate potential density [R ~> kg m-3] + real :: dp_in(GV%ke) ! The input column of layer thicknesses [H ~> m or kg m-2] + logical :: PCM_lay(GV%ke) ! If true for a layer, use PCM remapping for that layer + + ! These arrays are on the target grid. + real :: Rcv_tgt(CS%nk) ! Target potential density [R ~> kg m-3] + real :: Rcv(CS%nk) ! Initial values of coordinate potential density on the target grid [R ~> kg m-3] + real :: h_col(CS%nk) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: dz_int(CS%nk+1) ! The change in interface height due to remapping [H ~> m or kg m-2] + real :: Rcv_integral ! Integrated coordinate potential density in a layer [R H ~> kg m-2 or kg2 m-5] + + real :: qhrlx(CS%nk+1) ! Fractional relaxation within a timestep (between 0 and 1) [nondim] + real :: dp0ij(CS%nk) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(CS%nk+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + integer :: fixlay ! Deepest fixed coordinate layer + integer, dimension(0:CS%nk) :: k_end ! The index of the deepest source layer that contributes to + ! each target layer, in the unusual case where the the input grid is + ! larger than the new grid. This situation only occurs during certain + ! types of initialization or when generating output diagnostics. + integer :: i, j, k, nk, k2, nk_in + + nk = CS%nk + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + ! Store one-dimensional arrays of thicknesses for the 'old' vertical grid before regridding + h_tot = 0.0 + do K=1,GV%ke + temp_in(k) = tv%T(i,j,k) + saln_in(k) = tv%S(i,j,k) + dp_in(k) = dp(i,j,k) + h_tot = h_tot + dp_in(k) + enddo + + ! This sets the input column's coordinate potential density from T and S. + call calculate_density(temp_in, saln_in, p_col, Rcv_in, tv%eqn_of_state) + + ! Set the initial properties on the new grid from the old grid. + nk_in = GV%ke + if (GV%ke > CS%nk) then ; do k=GV%ke,CS%nk+1,-1 + ! Remove any excess massless layers from the bottom of the input column. + if (dp_in(k) > 0.0) exit + nk_in = k-1 + enddo ; endif + + if (CS%nk >= nk_in) then + ! Simply copy over the common layers. This is the usual case. + do k=1,min(CS%nk,GV%ke) + h_col(k) = dp_in(k) + Rcv(k) = Rcv_in(k) + enddo + if (CS%nk > GV%ke) then + ! Pad out the input column with additional massless layers with the bottom properties. + ! This case only occurs during initialization or perhaps when writing diagnostics. + do k=GV%ke+1,CS%nk + Rcv(k) = Rcv_in(GV%ke) + h_col(k) = 0.0 + enddo + endif + else ! (CS%nk < nk_in) + ! The input column has more data than the output. For now, combine layers to + ! make them the same size, but there may be better approaches that should be taken. + ! This case only occurs during initialization or perhaps when writing diagnostics. + ! This case was not handled by the original Hycom code in hybgen.F90. + do k=0,CS%nk ; k_end(k) = (k * nk_in) / CS%nk ; enddo + do k=1,CS%nk + h_col(k) = 0.0 ; Rcv_integral = 0.0 + do k2=k_end(k-1) + 1,k_end(k) + h_col(k) = h_col(k) + dp_in(k2) + Rcv_integral = Rcv_integral + dp_in(k2)*Rcv_in(k2) + enddo + if (h_col(k) > GV%H_subroundoff) then + ! Take the volume-weighted average properties. + Rcv(k) = Rcv_integral / h_col(k) + else ! Take the properties of the topmost source layer that contributes. + Rcv(k) = Rcv_in(k_end(k-1) + 1) + endif + enddo + endif + + ! Set the target densities for the new layers. + do k=1,CS%nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + enddo + + ! The following block of code is used to trigger z* stretching of the targets heights. + nominalDepth = (G%bathyT(i,j) + G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Determine whether to require the use of PCM remapping from each source layer. + do k=1,GV%ke + if (CS%hybiso > 0.0) then + ! --- thin or isopycnal source layers are remapped with PCM. + PCM_lay(k) = (k > fixlay) .and. (abs(Rcv(k) - Rcv_tgt(k)) < CS%hybiso) + else ! hybiso==0.0, so purely isopycnal layers use PCM + PCM_lay(k) = .false. + endif ! hybiso + enddo !k + + ! Determine the new layer thicknesses. + call hybgen_column_regrid(CS, nk, CS%thkbot, CS%onem, & + 1.0e-11*US%kg_m3_to_R, Rcv_tgt, fixlay, qhrlx, dp0ij, & + dp0cum, Rcv, h_col, dz_int) + + ! Store the output from hybgenaij_regrid in 3-d arrays. + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = PCM_lay(k) + enddo ; endif + + do K=1,nk+1 + ! Note that dzInterface uses the opposite sign convention from the change in p. + dzInterface(i,j,K) = -dz_int(K) + enddo + + else + if (present(PCM_cell)) then ; do k=1,GV%ke + PCM_cell(i,j,k) = .false. + enddo ; endif + do k=1,CS%nk+1 ; dzInterface(i,j,k) = 0.0 ; enddo + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_regrid + +!> Initialize some of the variables that are used for regridding or unmixing, including the +!! stretched contraits on where the new interfaces can be. +subroutine hybgen_column_init(nk, nsigma, dp0k, ds0k, dp00i, topiso_i_j, & + qhybrlx, dpns, dsns, h_tot, dilate, h_col, & + fixlay, qhrlx, dp0ij, dp0cum) + integer, intent(in) :: nk !< The number of layers in the new grid + integer, intent(in) :: nsigma !< The number of sigma levels + real, intent(in) :: dp0k(nk) !< Layer deep z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: ds0k(nsigma) !< Layer shallow z-level spacing minimum thicknesses [H ~> m or kg m-2] + real, intent(in) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real, intent(in) :: topiso_i_j !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + real, intent(in) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] + real, intent(in) :: h_tot !< The sum of the initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dilate !< A factor by which to dilate the target positions + !! from z to z* [nondim] + real, intent(in) :: h_col(nk) !< Initial layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: dpns !< Vertical sum of dp0k [H ~> m or kg m-2] + real, intent(in) :: dsns !< Vertical sum of ds0k [H ~> m or kg m-2] + integer, intent(out) :: fixlay !< Deepest fixed coordinate layer + real, intent(out) :: qhrlx(nk+1) !< Fractional relaxation within a timestep (between 0 and 1) [nondim] + real, intent(out) :: dp0ij(nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(out) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + + ! --- -------------------------------------------------------------- + ! --- hybrid grid generator, single column - initialization. + ! --- -------------------------------------------------------------- + + ! Local variables + real :: qdep ! Total water column thickness as a fraction of dp0k (vs ds0k) [nondim] + real :: q ! A portion of the thickness that contributes to the new cell [H ~> m or kg m-2] + real :: p_int(nk+1) ! Interface depths [H ~> m or kg m-2] + integer :: k, fixall + + ! --- dpns = sum(dp0k(k),k=1,nsigma) + ! --- dsns = sum(ds0k(k),k=1,nsigma) + ! --- terrain following starts (on the deep side) at depth dpns and ends (on the + ! --- shallow side) at depth dsns and the depth of the k-th layer interface varies + ! --- linearly with total depth between these two reference depths. + if ((h_tot >= dilate * dpns) .or. (dpns <= dsns)) then + qdep = 1.0 ! Not terrain following - this column is too thick or terrain following is disabled. + elseif (h_tot <= dilate * dsns) then + qdep = 0.0 ! Not terrain following - this column is too thin + else + qdep = (h_tot - dilate * dsns) / (dilate * (dpns - dsns)) + endif + + if (qdep < 1.0) then + ! Terrain following or shallow fixed coordinates, qhrlx=1 and ignore dp00 + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 + dp0ij( 1) = dilate * (qdep*dp0k(1) + (1.0-qdep)*ds0k(1)) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + qhrlx( k+1) = 1.0 + dp0ij( k) = dilate * (qdep*dp0k(k) + (1.0-qdep)*ds0k(k)) + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int( k+1) = p_int(k) + h_col(k) + enddo !k + else + ! Not terrain following + p_int( 1) = 0.0 + dp0cum(1) = 0.0 + qhrlx( 1) = 1.0 !no relaxation in top layer + dp0ij( 1) = dilate * dp0k(1) + + dp0cum(2) = dp0cum(1) + dp0ij(1) + qhrlx( 2) = 1.0 !no relaxation in top layer + p_int( 2) = p_int(1) + h_col(1) + do k=2,nk + if ((dp0k(k) <= dp00i) .or. (dilate * dp0k(k) >= p_int(k) - dp0cum(k))) then + ! This layer is in fixed surface coordinates. + dp0ij(k) = dp0k(k) + qhrlx(k+1) = 1.0 + else + q = dp0k(k) * (dilate * dp0k(k) / ( p_int(k) - dp0cum(k)) ) ! A fraction between 0 and 1 of dp0 to use here. + if (dp00i >= q) then + ! This layer is much deeper than the fixed surface coordinates. + dp0ij(k) = dp00i + qhrlx(k+1) = qhybrlx + else + ! This layer spans the margins of the fixed surface coordinates. + ! In this case dp00i < q < dp0k. + dp0ij(k) = dilate * q + qhrlx(k+1) = qhybrlx * (dp0k(k) - dp00i) / & + ((dp0k(k) - q) + (q - dp00i)*qhybrlx) ! 1 at dp0k, qhybrlx at dp00i + endif + + ! The old equivalent code is: + ! hybrlx = 1.0 / qhybrlx + ! q = max( dp00i, dp0k(k) * (dp0k(k) / max(dp0k( k), p_int(k) - dp0cum(k)) ) ) + ! qts = 1.0 - (q-dp00i) / (dp0k(k) - dp00i) !0 at q = dp0k, 1 at q=dp00i + ! qhrlx( k+1) = 1.0 / (1.0 + qts*(hybrlx-1.0)) !1 at dp0k, qhybrlx at dp00i + endif + dp0cum(k+1) = dp0cum(k) + dp0ij(k) + p_int(k+1) = p_int(k) + h_col(k) + enddo !k + endif !qdep<1:else + + ! Identify the current fixed coordinate layers + fixlay = 1 !layer 1 always fixed + do k=2,nk + if (dp0cum(k) >= dilate * topiso_i_j) then + exit !layers k to nk might be isopycnal + endif + ! Top of layer is above topiso, i.e. always fixed coordinate layer + qhrlx(k+1) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + + fixall = fixlay + do k=fixall+1,nk + if (p_int(k+1) > dp0cum(k+1) + 0.1*dp0ij(k)) then + if ( (fixlay > fixall) .and. (p_int(k) > dp0cum(k)) ) then + ! --- The previous layer should remain fixed. + fixlay = fixlay-1 + endif + exit !layers k to nk might be isopycnal + endif + ! Sometimes fixed coordinate layer + qhrlx(k) = 1.0 !no relaxation in fixed layers + fixlay = fixlay+1 + enddo !k + +end subroutine hybgen_column_init + +!> The cushion function from Bleck & Benjamin, 1992, which returns a smoothly varying +!! but limited value that goes between dp0 and delp +real function cushn(delp, dp0) + real, intent(in) :: delp ! A thickness change [H ~> m or kg m-2] + real, intent(in) :: dp0 ! A non-negative reference thickness [H ~> m or kg m-2] + + ! These are the nondimensional parameters that define the cushion function. + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] + ! These are derivative nondimensional parameters. + ! real, parameter :: cusha = qqmn**2 * (qqmx-1.0) / (qqmx-qqmn)**2 + ! real, parameter :: I_qqmn = 1.0 / qqmn + real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 + real, parameter :: I_qqmx = 1.0 / qqmx + + ! --- if delp >= qqmx*dp0 >> dp0, cushn returns delp. + ! --- if delp <= qqmn*dp0 << -dp0, cushn returns dp0. + + ! This is the original version from Hycom. + ! qq = max(qqmn, min(qqmx, delp/dp0)) + ! cushn = dp0 * (1.0 + cusha * (1.0-I_qqmn*qq)**2) * max(1.0, delp/(dp0*qqmx)) + + ! This is mathematically equivalent, has one fewer divide, and works as intended even if dp0 = 0. + if (delp >= qqmx*dp0) then + cushn = delp + elseif (delp < qqmn*dp0) then + cushn = max(dp0, delp * I_qqmx) + else + cushn = max(dp0, delp * I_qqmx) * (1.0 + qq_scale * ((delp / dp0) - qqmn)**2) + endif + +end function cushn + +!> Create a new grid for a column of water using the Hybgen algorithm. +subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & + fixlay, qhrlx, dp0ij, dp0cum, Rcv, h_in, dp_int) + type(hybgen_regrid_CS), intent(in) :: CS !< hybgen regridding control structure + integer, intent(in) :: nk !< number of layers + real, intent(in) :: thkbot !< thickness of bottom boundary layer [H ~> m or kg m-2] + real, intent(in) :: onem !< one m in pressure units [H ~> m or kg m-2] + real, intent(in) :: epsil !< small nonzero density to prevent division by zero [R ~> kg m-3] + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx( nk+1) !< relaxation coefficient per timestep [nondim] + real, intent(in) :: dp0ij( nk) !< minimum layer thickness [H ~> m or kg m-2] + real, intent(in) :: dp0cum(nk+1) !< minimum interface depth [H ~> m or kg m-2] + real, intent(in) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + real, intent(in) :: h_in(nk) !< Layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: dp_int(nk+1) !< The change in interface positions [H ~> m or kg m-2] + + ! --- ------------------------------------------------------ + ! --- hybrid grid generator, single column - regrid. + ! --- ------------------------------------------------------ + + ! Local variables + real :: p_new ! A new interface position [H ~> m or kg m-2] + real :: pres_in(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: p_int(nk+1) ! layer interface positions [H ~> m or kg m-2] + real :: h_col(nk) ! Updated layer thicknesses [H ~> m or kg m-2] + real :: q_frac ! A fraction of a layer to entrain [nondim] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2] + real :: h_hat3 ! Thickness movement upward across the interface between layers k-2 and k-3 [H ~> m or kg m-2] + real :: h_hat2 ! Thickness movement upward across the interface between layers k-1 and k-2 [H ~> m or kg m-2] + real :: h_hat ! Thickness movement upward across the interface between layers k and k-1 [H ~> m or kg m-2] + real :: h_hat0 ! A first guess at thickness movement upward across the interface + ! between layers k and k-1 [H ~> m or kg m-2] + real :: dh_cor ! Thickness changes [H ~> m or kg m-2] + real :: tenm ! ten m in pressure units [H ~> m or kg m-2] + real :: onemm ! one mm in pressure units [H ~> m or kg m-2] + logical :: trap_errors + integer :: k + character(len=256) :: mesg ! A string for output messages + + ! This line needs to be consistent with the parameters set in cushn(). + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn + + !### These hard-coded parameters should be changed to run-time variables. + tenm = 10.0*onem + onemm = 0.001*onem + + trap_errors = .true. + + do K=1,nk+1 ; dp_int(K) = 0.0 ; enddo + + p_int(1) = 0.0 + do k=1,nk + h_col(k) = max(h_in(k), 0.0) + p_int(K+1) = p_int(K) + h_col(k) + enddo + h_min = min( CS%min_thickness, p_int(nk+1)/real(CS%nk) ) + + if (trap_errors) then + do K=1,nk+1 ; pres_in(K) = p_int(K) ; enddo + endif + + ! Try to restore isopycnic conditions by moving layer interfaces + ! qhrlx(k) are relaxation amounts per timestep. + + ! Maintain prescribed thickness in layer k <= fixlay + ! There may be massless layers at the bottom, so work upwards. + do k=min(nk-1,fixlay),1,-1 + p_new = min(dp0cum(k+1), p_int(nk+1) - (nk-k)*h_min) ! This could be positive or negative. + dh_cor = p_new - p_int(K+1) + if (k= h_min) exit ! usually get here quickly + dh_cor = h_min - h_col(k) ! This is positive. + h_col(k) = h_min ! = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(fixlay+1) + enddo + if (h_col(nk) < h_min) then ! This should be uncommon, and should only arise at the level of roundoff. + do k=nk,2,-1 + if (h_col(k) >= h_min) exit + dh_cor = h_col(k) - h_min ! dh_cor is negative. + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_min ! = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + enddo + endif + + ! Remap the non-fixed layers. + + ! In the Hycom version, this loop was fused the loop correcting water that is + ! too light, and it ran down the water column, but if there are a set of layers + ! that are very dense, that structure can lead to all of the water being remapped + ! into a single thick layer. Splitting the loops and running the loop upwards + ! (as is done here avoids that catastrophic problem for layers that are far from + ! their targets. However, this code is still prone to a thin-thick-thin null mode. + do k=nk,fixlay+2,-1 + ! This is how the Hycom code would do this loop: do k=fixlay+1,nk ; if (k>fixlay+1) then + + if ((Rcv(k) > Rcv_tgt(k) + epsil)) then + ! Water in layer k is too dense, so try to dilute with water from layer k-1 + ! Do not move interface if k = fixlay + 1 + + if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & + (p_int(k) <= dp0cum(k) + onem) .or. & + (h_col(k) <= h_col(k-1))) then + ! If layer k-1 is too light, there is a conflict in the direction the + ! inteface between them should move, so thicken the thinner of the two. + + if ((Rcv_tgt(k) - Rcv(k-1)) <= epsil) then + ! layer k-1 is far too dense, take the entire layer + ! If this code is working downward and this branch is repeated in a series + ! of successive layers, it can accumulate into a very thick homogenous layers. + h_hat0 = 0.0 ! This line was not in the Hycom version of hybgen.F90. + h_hat = dp0ij(k-1) - h_col(k-1) + else + ! Entrain enough from the layer above to bring layer k to its target density. + q_frac = (Rcv_tgt(k) - Rcv(k)) / (Rcv_tgt(k) - Rcv(k-1)) ! -1 <= q_frac < 0 + h_hat0 = q_frac*h_col(k) ! -h_col(k-1) <= h_hat0 < 0 + if (k == fixlay+2) then + ! Treat layer k-1 as fixed. + h_hat = max(h_hat0, dp0ij(k-1) - h_col(k-1)) + else + ! Maintain the minimum thickess of layer k-1. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !fixlay+2:else + endif + ! h_hat is usually negative, so this check may be unnecessary if the values of + ! dp0ij are limited to not be below the seafloor? + h_hat = min(h_hat, p_int(nk+1) - p_int(k)) + + ! If isopycnic conditions cannot be achieved because of a blocking + ! layer (thinner than its minimum thickness) in the interior ocean, + ! move interface k-1 (and k-2 if necessary) upward + ! Only work on layers that are sufficiently far from the fixed near-surface layers. + if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + tenm)) then + + ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. + if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & + (h_col(k-2) > qqmx*dp0ij(k-2)) ) then + ! Determine how much water layer k-2 could supply without becoming too thin. + if (k == fixlay+3) then + ! Treat layer k-2 as fixed. + h_hat2 = max(h_hat0 - h_hat, dp0ij(k-2) - h_col(k-2)) + else + ! Maintain minimum thickess of layer k-2. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + endif !fixlay+3:else + + if (h_hat2 < -onemm) then + dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + elseif (k <= fixlay+3) then + ! Do nothing. + elseif (p_int(k-2) > dp0cum(k-2) + tenm .and. & + (p_int(nk+1) - p_int(k-2) < thkbot .or. & + h_col(k-3) > qqmx*dp0ij(k-3))) then + + ! Determine how much water layer k-3 could supply without becoming too thin. + if (k == fixlay+4) then + ! Treat layer k-3 as fixed. + h_hat3 = max(h_hat0 - h_hat, dp0ij(k-3) - h_col(k-3)) + else + ! Maintain minimum thickess of layer k-3. + h_hat3 = cushn(h_col(k-3) + (h_hat0 - h_hat), dp0ij(k-3)) - h_col(k-3) + endif !fixlay+4:else + if (h_hat3 < -onemm) then + ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. + dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) + h_col(k-3) = h_col(k-3) + dh_cor + h_col(k-2) = h_col(k-2) - dh_cor + dp_int(k-2) = dp_int(k-2) + dh_cor + p_int(k-2) = p_int(k-2) + dh_cor + + ! Now layer k-2 might be able donate to layer k-1. + h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) + if (h_hat2 < -onemm) then + dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) + h_col(k-2) = h_col(k-2) + dh_cor + h_col(k-1) = h_col(k-1) - dh_cor + dp_int(k-1) = dp_int(k-1) + dh_cor + p_int(k-1) = p_int(k-1) + dh_cor + ! Recalculate how much layer k-1 could donate to layer k. + h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) + endif !h_hat2 + endif !h_hat3 + endif !h_hat2:blocking + endif ! Layer k-2 could move. + endif ! blocking, i.e., h_hat >= 0, and far enough from the fixed layers to permit a change. + + if (h_hat < 0.0) then + ! entrain layer k-1 water into layer k, move interface up. + dh_cor = qhrlx(k) * h_hat + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif !entrain + + endif !too-dense adjustment + endif + + ! In the original Hycom version, there is not a break between these two loops. + enddo + + do k=fixlay+1,nk + if (Rcv(k) < Rcv_tgt(k) - epsil) then ! layer too light + ! Water in layer k is too light, so try to dilute with water from layer k+1. + ! Entrainment is not possible if layer k touches the bottom. + if (p_int(k+1) < p_int(nk+1)) then ! k dp0ij(k) + dp0ij(k+1)) then + h_hat = h_col(k+1) - cushn(h_col(k+1) - h_hat, dp0ij(k+1)) + endif + ! Try to bring layer layer k up to its minimum thickness. + h_hat = max(h_hat, dp0ij(k) - h_col(k)) + ! Do not drive layer k+1 below its minimum thickness or take more than half of it. + h_hat = min(h_hat, max(0.5*h_col(k+1), h_col(k+1) - dp0ij(k+1)) ) + else + ! Layers that touch the bottom can lose their entire contents. + h_hat = min(h_col(k+1), h_hat) + endif !p.k+2 0.0) then + ! Entrain layer k+1 water into layer k. + dh_cor = qhrlx(k+1) * h_hat + h_col(k) = h_col(k) + dh_cor + h_col(k+1) = h_col(k+1) - dh_cor + dp_int(k+1) = dp_int(k+1) + dh_cor + p_int(k+1) = p_int(k+1) + dh_cor + endif !entrain + + endif !too-light adjustment + endif !above bottom + endif !too light + + ! If layer above is still too thin, move interface down. + dh_cor = min(qhrlx(k-1) * min(dp0ij(k-1) - h_col(k-1), p_int(nk+1) - p_int(k)), h_col(k)) + if (dh_cor > 0.0) then + h_col(k-1) = h_col(k-1) + dh_cor + h_col(k) = h_col(k) - dh_cor + dp_int(k) = dp_int(k) + dh_cor + p_int(k) = p_int(k) + dh_cor + endif + + enddo !k Hybrid vertical coordinate relocation moving interface downward + + if (trap_errors) then + ! Verify that everything is consistent. + do k=1,nk + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) + call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) + endif + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), onem)) then + write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & + k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay + call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) + endif + enddo + do K=1,nk+1 + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), onem)) then + call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") + endif + enddo + endif + +end subroutine hybgen_column_regrid + +end module MOM_hybgen_regrid + +! This code was translated in 2022 from the HYCOM hybgen code, which was primarily developed +! between 2000 and 2015, with some minor subsequent changes and bug fixes. diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 new file mode 100644 index 0000000000..213c6c677e --- /dev/null +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -0,0 +1,390 @@ +!> This module contains the hybgen remapping routines from HYCOM, with minor +!! modifications to follow the MOM6 coding conventions +module MOM_hybgen_remap + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + +contains + +!> Set up the coefficients for PLM remapping of a set of scalars +subroutine hybgen_plm_coefs(si, dpi, slope, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: si(nk,ns) !< The cell-averaged input scalar fields [A] + real, intent(in) :: dpi(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: slope(nk,ns) !< The PLM slope times cell width [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: piecewise linear across each input cell with +! monotonized central-difference limiter. +! +! van Leer, B., 1977, J. Comp. Phys., 23 276-299. +! +! 2) input arguments: +! si - initial scalar fields in pi-layer space +! dpi - initial layer thicknesses (dpi(k) = pi(k+1)-pi(k)) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! slope - coefficients for hybgen_plm_remap +! profile(y) = si+slope*(y-1), -0.5 <= y <= 0.5 +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: qcen ! A layer's thickness divided by the distance between the centers + ! of the adjacent cells, usually ~0.5, but always <= 1 [nondim] + real :: zbot, zcen, ztop ! Tracer slopes times the layer thickness [A] + integer :: i, k + + do i=1,ns + slope(1, i) = 0.0 + slope(nk,i) = 0.0 + enddo !i + do k= 2,nk-1 + if (dpi(k) <= thin) then !use PCM + do i=1,ns ; slope(k,i) = 0.0 ; enddo + else +! --- use qcen in place of 0.5 to allow for non-uniform grid + qcen = dpi(k) / (dpi(k)+0.5*(dpi(k-1)+dpi(k+1))) !dpi(k)>thin + do i=1,ns +! --- PLM (non-zero slope, but no new extrema) +! --- layer value is si-0.5*slope at top interface, +! --- and si+0.5*slope at bottom interface. +! +! --- monotonized central-difference limiter (van Leer, 1977, +! --- JCP 23 pp 276-299). For a discussion of PLM limiters, see +! --- Finite Volume Methods for Hyperbolic Problems by R.J. Leveque. + ztop = 2.0*(si(k, i)-si(k-1,i)) + zbot = 2.0*(si(k+1,i)-si(k, i)) + zcen = qcen*(si(k+1,i)-si(k-1,i)) + if (ztop*zbot > 0.0) then !ztop,zbot are the same sign + slope(k,i) = sign(min(abs(zcen),abs(zbot),abs(ztop)), zbot) + else + slope(k,i) = 0.0 !local extrema, so no slope + endif + enddo !i + endif !PCM:PLM + enddo !k + + if (present(PCM_lay)) then + do k=1,nk ; if (PCM_lay(k)) then + do i=1,ns ; slope(k,i) = 0.0 ; enddo + endif ; enddo + endif + +end subroutine hybgen_plm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The PPM interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic piecewise parabolic across each input cell +! +! Colella, P. & P.R. Woodward, 1984, J. Comp. Phys., 54, 174-201. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the PPM reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Tim Campbell, Mississippi State University, October 2002. +! Alan J. Wallcraft, Naval Research Laboratory, Aug. 2007. +!----------------------------------------------------------------------- +! + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell. + real :: as(nk) ! Scalar field difference across each cell [A] + real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] + real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(nk+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(nk) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(nk) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(nk+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k, i + + ! This PPM remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,nk-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,nk-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + do i=1,ns + !Compute average slopes: Colella, Eq. (1.8) + as(1) = 0. + do k=2,nk-1 + if (PCM_layer(k)) then !use PCM + as(k) = 0.0 + else + slk = s(k, i)-s(k-1,i) + srk = s(k+1,i)-s(k, i) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + as(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + as(k) = 0. + endif + endif !PCM:PPM + enddo !k + as(nk) = 0. + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = s(1,i) ! 1st layer PCM + ar(1) = s(1,i) ! 1st layer PCM + al(2) = s(1,i) ! 1st layer PCM + do K=3,nk-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*s(k-1,i) + dp(k-1)*s(k,i)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(s(k,i)-s(k-1,i)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*as(k-1)*h23_h122(K) - dp(k-1)*as(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(nk-1) = s(nk,i) ! last layer PCM + al(nk) = s(nk,i) ! last layer PCM + ar(nk) = s(nk,i) ! last layer PCM + !Impose monotonicity: Colella, Eq. (1.10) + do k=2,nk-1 + if ((PCM_layer(k)) .or. ((s(k+1,i)-s(k,i))*(s(k,i)-s(k-1,i)) <= 0.)) then !local extremum + al(k) = s(k,i) + ar(k) = s(k,i) + else + da = ar(k)-al(k) + a6 = 6.0*s(k,i) - 3.0*(al(k)+ar(k)) + if (da*a6 > da*da) then !peak in right half of zone + al(k) = 3.0*s(k,i) - 2.0*ar(k) + elseif (da*a6 < -da*da) then !peak in left half of zone + ar(k) = 3.0*s(k,i) - 2.0*al(k) + endif + endif + enddo !k + !Set coefficients + do k=1,nk + edges(k,1,i) = al(k) + edges(k,2,i) = ar(k) + enddo !k + enddo !i + +end subroutine hybgen_ppm_coefs + + +!> Set up the coefficients for PPM remapping of a set of scalars +subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) + integer, intent(in) :: nk !< The number of input layers + integer, intent(in) :: ns !< The number of scalar fields to work on + real, intent(in) :: s(nk,ns) !< The input scalar fields [A] + real, intent(in) :: h_src(nk) !< The input grid layer thicknesses [H ~> m or kg m-2] + real, intent(out) :: edges(nk,2,ns) !< The WENO interpolation edge values of the scalar fields [A] + real, intent(in) :: thin !< A negligible layer thickness that can be ignored [H ~> m or kg m-2] + logical, optional, intent(in) :: PCM_lay(nk) !< If true for a layer, use PCM remapping for that layer + +!----------------------------------------------------------------------- +! 1) coefficients for remapping from one set of vertical cells to another. +! method: monotonic WENO-like alternative to PPM across each input cell +! a second order polynomial approximation of the profiles +! using a WENO reconciliation of the slopes to compute the +! interfacial values +! +! This scheme might have ben developed by Shchepetkin. A.F., personal communication. +! See also Engwirda, D., and M. Kelley, A WENO-type slope-limiter for a family of piecewise +! polynomial methods, arXive:1606.08188v1, 27 June 2016. +! +! 2) input arguments: +! s - initial scalar fields in pi-layer space +! h_src - initial layer thicknesses (>=0) +! nk - number of layers +! ns - number of fields +! thin - layer thickness (>0) that can be ignored +! PCM_lay - use PCM for selected layers (optional) +! +! 3) output arguments: +! edges - cell edge scalar values for the WENO reconstruction +! edges.1 is value at interface above +! edges.2 is value at interface below +! +! 4) Laurent Debreu, Grenoble. +! Alan J. Wallcraft, Naval Research Laboratory, July 2008. +!----------------------------------------------------------------------- +! +! real, parameter :: dsmll=1.0e-8 ! This has units of [A2], and hence can not be a parameter. +! + real :: curv_cell ! An estimate of the tracer curvature centered on a cell times the grid + ! spacing [A H-1 ~> A m-1 or A kg m-2] + real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] + real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] + real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] + logical :: PCM_layer(nk) ! True for layers that should use PCM remapping, either because they are + ! very thin, or because this is specified by PCM_lay. + real :: dp(nk) ! Input grid layer thicknesses, but with a minimum thickness given by thin [H ~> m or kg m-2] + real :: qdpkm(nk) ! Inverse of the sum of two adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: qdpkmkp(nk) ! Inverse of the sum of three adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: dpkm2kp(nk) ! Twice the distance between the centers of the layers two apart [H ~> m or kg m-2] + real :: zw(nk,2) ! Squared combinations of the differences between the the cell average tracer + ! concentrations and the left and right edges [A2] + real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim] + real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim] + real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A kg m-2] + real :: val_edge(nk+1) ! A weighted average edge concentration [A] + integer :: i, k + + min_ratio = 1.0e-8 + + ! The WENO remapper is not currently written to work with massless layers, so set + ! the thicknesses for very thin layers to some minimum value. + do k=1,nk ; dp(k) = max(h_src(k), thin) ; enddo + + ! Specify the layers that will use PCM remapping. + if (present(PCM_lay)) then + do k=1,nk ; PCM_layer(k) = (PCM_lay(k) .or. dp(k) <= thin) ; enddo + else + do k=1,nk ; PCM_layer(k) = (dp(k) <= thin) ; enddo + endif + + !compute grid metrics + do k=2,nk-1 + qdpkm( K) = 1.0 / (dp(k-1) + dp(k)) + qdpkmkp(k) = 1.0 / (dp(k-1) + dp(k) + dp(k+1)) + dpkm2kp(k) = dp(k-1) + 2.0*dp(k) + dp(k+1) + enddo !k + qdpkm(nk) = 1.0 / (dp(nk-1) + dp(nk)) + + do i=1,ns + do K=2,nk + slope_edge(K) = qdpkm(K) * (s(k,i)-s(k-1,i)) + enddo !k + k = 1 !PCM first layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + do k=2,nk-1 + if ((slope_edge(K)*slope_edge(K+1) < 0.0) .or. PCM_layer(k)) then !use PCM + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k,1) = 0.0 + zw(k,2) = 0.0 + else + seh1 = dp(k)*slope_edge(K+1) + seh2 = dp(k)*slope_edge(K) + q01 = dpkm2kp(k)*slope_edge(K+1) + q02 = dpkm2kp(k)*slope_edge(K) + if (abs(seh1) > abs(q02)) then + seh1 = q02 + endif + if (abs(seh2) > abs(q01)) then + seh2 = q01 + endif + curv_cell = (seh1 - seh2) * qdpkmkp(k) + q001 = seh1 - curv_cell*dp(k+1) + q002 = seh2 + curv_cell*dp(k-1) + ! q001 = (seh1 * (dp(k-1) + dp(k)) + seh2 * dp(k+1)) * qdpkmkp(k) + ! q002 = (seh2 * (dp(k+1) + dp(k)) + seh1 * dp(k-1)) * qdpkmkp(k) + + edges(k,2,i) = s(k,i) + q001 + edges(k,1,i) = s(k,i) - q002 + zw(k,1) = (2.0*q001 - q002)**2 + zw(k,2) = (2.0*q002 - q001)**2 + endif !PCM:WENO + enddo !k + k = nk !PCM last layer + edges(k,1,i) = s(k,i) + edges(k,2,i) = s(k,i) + zw(k, 1) = 0.0 + zw(k, 2) = 0.0 + + do k=2,nk + ! This was the original code based on that in Hycom, but because zw has + ! dimensions of [A2], it can not use a constant (hard coded) value of dsmll. + ! ds2a = max(zw(k-1,2), dsmll) + ! ds2b = max(zw(k, 1), dsmll) + ! val_edge(K) = (ds2b*edges(k-1,2,i)+ds2a*edges(k,1,i)) / (ds2b+ds2a) + ! Use a weighted average of the two layers' estimated edge values as the actual edge value. + if (zw(k,1) + zw(k-1,2) <= 0.0) then + wt1 = 0.5 + elseif (zw(k,1) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = min_ratio + elseif (zw(k-1,2) <= min_ratio * (zw(k,1) + zw(k-1,2))) then + wt1 = (1.0 - min_ratio) + else + wt1 = zw(k,1) / (zw(k,1) + zw(k-1,2)) + endif + val_edge(k) = wt1*edges(k-1,2,i) + (1.0-wt1)*edges(k,1,i) + enddo !k + val_edge( 1) = 2.0*s( 1,i)-val_edge( 2) !not used? + val_edge(nk+1) = 2.0*s(nk,i)-val_edge(nk) !not used? + + do k=2,nk-1 + if (.not.PCM_layer(k)) then !don't use PCM + q01 = val_edge(K+1) - s(k,i) + q02 = s(k,i) - val_edge(K) + if (q01*q02 < 0.0) then + q01 = 0.0 + q02 = 0.0 + elseif (abs(q01) > abs(2.0*q02)) then + q01 = 2.0*q02 + elseif (abs(q02) > abs(2.0*q01)) then + q02 = 2.0*q01 + endif + edges(k,1,i) = s(k,i) - q02 + edges(k,2,i) = s(k,i) + q01 + endif ! PCM:WENO + enddo !k + enddo !i + +end subroutine hybgen_weno_coefs + +end module MOM_hybgen_remap diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 new file mode 100644 index 0000000000..a2b94d846b --- /dev/null +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -0,0 +1,499 @@ +!> This module contains the hybgen unmixing routines from HYCOM, with +!! modifications to follow the MOM6 coding conventions and several bugs fixed +module MOM_hybgen_unmix + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type, calculate_density, calculate_density_derivs +use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, param_file_type, log_param +use MOM_hybgen_regrid, only : hybgen_column_init +use MOM_hybgen_regrid, only : hybgen_regrid_CS, get_hybgen_regrid_params +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : ocean_grid_type, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +#include + +!> Control structure containing required parameters for the hybgen coordinate generator +type, public :: hybgen_unmix_CS ; private + + integer :: nsigma !< Number of sigma levels used by HYBGEN + real :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] + + real :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] + real :: qhybrlx !< Hybgen relaxation amount per thermodynamic time steps [nondim] + + real, allocatable, dimension(:) :: & + dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] + ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] + + real :: dpns !< depth to start terrain following [H ~> m or kg m-2] + real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] + real :: min_dilate !< The minimum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when wetting occurs. + real :: max_dilate !< The maximum amount of dilation that is permitted when converting target + !! coordinates from z to z* [nondim]. This limit applies when drying occurs. + + real :: topiso_const !< Shallowest depth for isopycnal layers [H ~> m or kg m-2] + ! real, dimension(:,:), allocatable :: topiso + + real :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] + real, allocatable, dimension(:) :: target_density !< Nominal density of interfaces [R ~> kg m-3] + +end type hybgen_unmix_CS + +public hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix +public set_hybgen_unmix_params + +contains + +!> Initialise a hybgen_unmix_CS control structure and store its parameters +subroutine init_hybgen_unmix(CS, GV, US, param_file, hybgen_regridCS) + type(hybgen_unmix_CS), pointer :: CS !< Unassociated pointer to hold the control 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 + type(hybgen_regrid_CS), pointer :: hybgen_regridCS !< Control structure for hybgen + !! regridding for sharing parameters. + integer :: k + + if (associated(CS)) call MOM_error(FATAL, "init_hybgen_unmix: CS already associated!") + allocate(CS) + allocate(CS%target_density(GV%ke)) + + allocate(CS%dp0k(GV%ke), source=0.0) ! minimum deep z-layer separation + allocate(CS%ds0k(GV%ke), source=0.0) ! minimum shallow z-layer separation + + ! Set the parameters for the hybgen unmixing from a hybgen regridding control structure. + call get_hybgen_regrid_params(hybgen_regridCS, ref_pressure=CS%ref_pressure, & + nsigma=CS%nsigma, dp0k=CS%dp0k, ds0k=CS%ds0k, & + dp00i=CS%dp00i, topiso_const=CS%topiso_const, qhybrlx=CS%qhybrlx, & + hybiso=CS%hybiso, min_dilate=CS%min_dilate, max_dilate=CS%max_dilate, & + target_density=CS%target_density) + + ! Determine the depth range over which to use a sigma (terrain-following) coordinate. + ! --- terrain following starts at depth dpns and ends at depth dsns + if (CS%nsigma == 0) then + CS%dpns = CS%dp0k(1) + CS%dsns = 0.0 + else + CS%dpns = 0.0 + CS%dsns = 0.0 + do k=1,CS%nsigma + CS%dpns = CS%dpns + CS%dp0k(k) + CS%dsns = CS%dsns + CS%ds0k(k) + enddo !k + endif !nsigma + +end subroutine init_hybgen_unmix + +!> This subroutine deallocates memory in the control structure for the hybgen unmixing module +subroutine end_hybgen_unmix(CS) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate control structure + + ! nothing to do + if (.not. associated(CS)) return + + deallocate(CS%target_density) + deallocate(CS%dp0k, CS%ds0k) + deallocate(CS) +end subroutine end_hybgen_unmix + +!> This subroutine can be used to set the parameters for the hybgen module +subroutine set_hybgen_unmix_params(CS, min_thickness) + type(hybgen_unmix_CS), pointer :: CS !< Coordinate unmixing control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + + if (.not. associated(CS)) call MOM_error(FATAL, "set_hybgen_params: CS not associated") + +! if (present(min_thickness)) CS%min_thickness = min_thickness +end subroutine set_hybgen_unmix_params + + +!> Unmix the properties in the lowest layer with mass if it is too light, and make +!! any other changes to the water column to prepare for regridding. +subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen control structure + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry structure + integer, intent(in) :: ntr !< The number of tracers in the registry, or + !! 0 if the registry is not in use. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + +! --- -------------------------------------------- +! --- hybrid grid generator, single j-row (part A). +! --- -------------------------------------------- + + character(len=256) :: mesg ! A string for output messages + integer :: fixlay ! deepest fixed coordinate layer + real :: qhrlx( GV%ke+1) ! relaxation coefficient per timestep [nondim] + real :: dp0ij( GV%ke) ! minimum layer thickness [H ~> m or kg m-2] + real :: dp0cum(GV%ke+1) ! minimum interface depth [H ~> m or kg m-2] + + real :: Rcv_tgt(GV%ke) ! Target potential density [R ~> kg m-3] + real :: temp(GV%ke) ! A column of potential temperature [degC] + real :: saln(GV%ke) ! A column of salinity [ppt] + real :: Rcv(GV%ke) ! A column of coordinate potential density [R ~> kg m-3] + real :: h_col(GV%ke) ! A column of layer thicknesses [H ~> m or kg m-2] + real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] + real :: tracer(GV%ke,max(ntr,1)) ! Columns of each tracer [Conc] + real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] + real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: h_thin ! A negligibly small thickness to identify essentially + ! vanished layers [H ~> m or kg m-2] + real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] + + real :: Th_tot_in, Th_tot_out ! Column integrated temperature [degC H ~> degC m or degC kg m-2] + real :: Sh_tot_in, Sh_tot_out ! Column integrated salinity [ppt H ~> ppt m or ppt kg m-2] + real :: Trh_tot_in(max(ntr,1)) ! Initial column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + real :: Trh_tot_out(max(ntr,1)) ! Final column integrated tracer amounts [conc H ~> conc m or conc kg m-2] + + logical :: debug_conservation ! If true, test for non-conservation. + logical :: terrain_following ! True if this column is terrain following. + integer :: trcflg(max(ntr,1)) ! Hycom tracer type flag for each tracer + integer :: i, j, k, nk, m + + nk = GV%ke + + ! Set all tracers to be passive. Setting this to 2 treats a tracer like temperature. + trcflg(:) = 3 + + h_thin = 1e-6*GV%m_to_H + debug_conservation = .false. ! Set this to true for debugging + + p_col(:) = CS%ref_pressure + + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then + + h_tot = 0.0 + do k=1,nk + ! Rcv_tgt(k) = theta(i,j,k) ! If a 3-d target density were set up in theta, use that here. + Rcv_tgt(k) = CS%target_density(k) ! MOM6 does not yet support 3-d target densities. + h_col(k) = h(i,j,k) + h_tot = h_tot + h_col(k) + temp(k) = tv%T(i,j,k) + saln(k) = tv%S(i,j,k) + enddo + + ! This sets the potential density from T and S. + call calculate_density(temp, saln, p_col, Rcv, tv%eqn_of_state) + + do m=1,ntr ; do k=1,nk + tracer(k,m) = Reg%Tr(m)%t(i,j,k) + enddo ; enddo + + ! Store original amounts to test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_in = 0.0 ; Sh_tot_in = 0.0 ; Trh_tot_in(:) = 0.0 + do k=1,nk + Sh_tot_in = Sh_tot_in + h_col(k)*saln(k) + Th_tot_in = Th_tot_in + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_in(m) = Trh_tot_in(m) + h_col(k)*tracer(k,m) + enddo ; enddo + endif + + ! The following block of code is used to trigger z* stretching of the targets heights. + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif + + terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) + + ! Convert the regridding parameters into specific constraints for this column. + call hybgen_column_init(nk, CS%nsigma, CS%dp0k, CS%ds0k, CS%dp00i, & + CS%topiso_const, CS%qhybrlx, CS%dpns, CS%dsns, h_tot, dilate, & + h_col, fixlay, qhrlx, dp0ij, dp0cum) + + ! Do any unmixing of the column that is needed to move the layer properties toward their targets. + call hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, tv%eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + + ! Store the output from hybgen_unmix in the 3-d arrays. + do k=1,nk + h(i,j,k) = h_col(k) + enddo + ! Note that temperature and salinity are among the tracers unmixed here. + do m=1,ntr ; do k=1,nk + Reg%Tr(m)%t(i,j,k) = tracer(k,m) + enddo ; enddo + ! However, temperature and salinity may have been treated differently from other tracers. + do k=1,nk + tv%T(i,j,k) = temp(k) + tv%S(i,j,k) = saln(k) + enddo + + ! Test for conservation of temperature, salinity, and tracers. + if (debug_conservation) then + Th_tot_out = 0.0 ; Sh_tot_out = 0.0 ; Trh_tot_out(:) = 0.0 + do k=1,nk + Sh_tot_out = Sh_tot_out + h_col(k)*saln(k) + Th_tot_out = Th_tot_out + h_col(k)*temp(k) + enddo + do m=1,ntr ; do k=1,nk + Trh_tot_out(m) = Trh_tot_out(m) + h_col(k)*tracer(k,m) + enddo ; enddo + if (abs(Sh_tot_in - Sh_tot_out) > 1.e-15*(abs(Sh_tot_in) + abs(Sh_tot_out))) then + write(mesg, '("i,j=",2i8,"Sh_tot = ",2es17.8," err = ",es13.4)') & + i, j, Sh_tot_in, Sh_tot_out, (Sh_tot_in - Sh_tot_out) + call MOM_error(FATAL, "Mismatched column salinity in hybgen_unmix: "//trim(mesg)) + endif + if (abs(Th_tot_in - Th_tot_out) > 1.e-10*(abs(Th_tot_in) + abs(Th_tot_out))) then + write(mesg, '("i,j=",2i8,"Th_tot = ",2es17.8," err = ",es13.4)') & + i, j, Th_tot_in, Th_tot_out, (Th_tot_in - Th_tot_out) + call MOM_error(FATAL, "Mismatched column temperature in hybgen_unmix: "//trim(mesg)) + endif + do m=1,ntr + if (abs(Trh_tot_in(m) - Trh_tot_out(m)) > 1.e-10*(abs(Trh_tot_in(m)) + abs(Trh_tot_out(m)))) then + write(mesg, '("i,j=",2i8,"Trh_tot(",i2,") = ",2es17.8," err = ",es13.4)') & + i, j, m, Trh_tot_in(m), Trh_tot_out(m), (Trh_tot_in(m) - Trh_tot_out(m)) + call MOM_error(FATAL, "Mismatched column tracer in hybgen_unmix: "//trim(mesg)) + endif + enddo + endif + endif ; enddo ; enddo !i & j. + +end subroutine hybgen_unmix + + +!> Unmix the properties in the lowest layer if it is too light. +subroutine hybgen_column_unmix(CS, nk, Rcv_tgt, temp, saln, Rcv, eqn_of_state, & + ntr, tracer, trcflg, fixlay, qhrlx, h_col, & + terrain_following, h_thin) + type(hybgen_unmix_CS), intent(in) :: CS !< hybgen unmixing control structure + integer, intent(in) :: nk !< The number of layers + integer, intent(in) :: fixlay !< deepest fixed coordinate layer + real, intent(in) :: qhrlx(nk+1) !< Relaxation fraction per timestep [nondim], < 1. + real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] + real, intent(inout) :: temp(nk) !< A column of potential temperature [degC] + real, intent(inout) :: saln(nk) !< A column of salinity [ppt] + real, intent(inout) :: Rcv(nk) !< Coordinate potential density [R ~> kg m-3] + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: ntr !< The number of registered passive tracers + real, intent(inout) :: tracer(nk, max(ntr,1)) !< Columns of the passive tracers [Conc] + integer, intent(in) :: trcflg(max(ntr,1)) !< Hycom tracer type flag for each tracer + real, intent(inout) :: h_col(nk+1) !< Layer thicknesses [H ~> m or kg m-2] + logical, intent(in) :: terrain_following !< True if this column is terrain following + real, intent(in) :: h_thin !< A negligibly small thickness to identify + !! essentially vanished layers [H ~> m or kg m-2] + +! +! --- ------------------------------------------------------------------ +! --- hybrid grid generator, single column - ummix lowest massive layer. +! --- ------------------------------------------------------------------ +! + ! Local variables + real :: h_hat ! A portion of a layer to move across an interface [H ~> m or kg m-2] + real :: delt, deltm ! Temperature differences between successive layers [degC] + real :: dels, delsm ! Salinity differences between successive layers [ppt] + real :: abs_dRdT ! The absolute value of the derivative of the coordinate density + ! with temperature [R degC-1 ~> kg m-3 degC-1] + real :: abs_dRdS ! The absolute value of the derivative of the coordinate density + ! with salinity [R ppt-1 ~> kg m-3 ppt-1] + real :: q, qts ! Nondimensional fractions in the range of 0 to 1 [nondim] + real :: frac_dts ! The fraction of the temperature or salinity difference between successive + ! layers by which the source layer's property changes by the loss of water + ! that matches the destination layers properties via unmixing [nondim]. + real :: qtr ! The fraction of the water that will come from the layer below, + ! used for updating the concentration of passive tracers [nondim] + real :: swap_T ! A swap variable for temperature [degC] + real :: swap_S ! A swap variable for salinity [ppt] + real :: swap_tr ! A temporary swap variable for the tracers [conc] + logical, parameter :: lunmix=.true. ! unmix a too light deepest layer + integer :: k, ka, kp, kt, m + + ! --- identify the deepest layer kp with significant thickness (> h_thin) + kp = 2 !minimum allowed value + do k=nk,3,-1 + if (h_col(k) >= h_thin) then + kp = k + exit + endif + enddo !k + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 +! + if ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + ((Rcv(k-1) > Rcv(k)) .and. (Rcv(ka) > Rcv(k))) ) then +! +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the two layers above. +! --- +! --- this should only occur when relaxing or nudging layer thickness +! --- and is a bug (bad interaction with tsadvc) even in those cases +! --- +! --- entrain the entire layer into the one above +!--- note the double negative in T=T-q*(T-T'), equiv. to T=T+q*(T'-T) + q = h_col(k) / (h_col(k) + h_col(k-1)) + temp(k-1) = temp(k-1) - q*(temp(k-1) - temp(k)) + saln(k-1) = saln(k-1) - q*(saln(k-1) - saln(k)) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + tracer(k-1,m) = tracer(k-1,m) - q*(tracer(k-1,m) - tracer(k,m) ) + enddo !m +! --- entrained the entire layer into the one above, so now kp=kp-1 + h_col(k-1) = h_col(k-1) + h_col(k) + h_col(k) = 0.0 + kp = k-1 + elseif ( ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv_tgt(k) > Rcv(k)) .and. & ! layer is lighter than its target + (Rcv(k-1) > Rcv(k)) ) then +! --- water in the deepest inflated layer with significant thickness +! --- (kp) is too light, and it is lighter than the layer above, but not the layer two above. +! --- +! --- swap the entire layer with the one above. + if (h_col(k) <= h_col(k-1)) then + ! The bottom layer is thinner; swap the entire bottom layer with a portion of the layer above. + q = h_col(k) / h_col(k-1) !<=1.0 + + swap_T = temp(k-1) + temp(k-1) = temp(k-1) + q*(temp(k) - temp(k-1)) + temp(k) = swap_T + + swap_S = saln(k-1) + saln(k-1) = saln(k-1) + q*(saln(k) - saln(k-1)) + saln(k) = swap_S + + Rcv(k) = Rcv(k-1) + call calculate_density(temp(k-1), saln(k-1), CS%ref_pressure, Rcv(k-1), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k-1,m) + tracer(k-1,m) = tracer(k-1,m) - q * (tracer(k-1,m) - tracer(k,m)) + tracer(k,m) = swap_tr + enddo !m + else + ! The bottom layer is thicker; swap the entire layer above with a portion of the bottom layer. + q = h_col(k-1) / h_col(k) !<1.0 + + swap_T = temp(k) + temp(k) = temp(k) + q*(temp(k-1) - temp(k)) + temp(k-1) = swap_T + + swap_S = saln(k) + saln(k) = saln(k) + q*(saln(k-1) - saln(k)) + saln(k-1) = swap_S + + Rcv(k-1) = Rcv(k) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + do m=1,ntr + swap_tr = tracer(k,m) + tracer(k,m) = tracer(k,m) + q * (tracer(k-1,m) - tracer(k,m)) + tracer(k-1,m) = swap_tr + enddo !m + endif !bottom too light + endif + + k = kp !at least 2 + ka = max(k-2,1) !k might be 2 + + if ( lunmix .and. & ! usually .true. + ((k > fixlay+1) .and. (.not.terrain_following)) .and. & ! layer not fixed depth + (h_col(k-1) >= h_thin) .and. & ! layer above not too thin + (Rcv(k) < Rcv_tgt(k)) .and. & ! layer is lighter than its target + (Rcv(k) > Rcv_tgt(k-1)) .and. & ! layer is denser than the target above + (abs(Rcv_tgt(k-1) - Rcv(k-1)) < CS%hybiso) .and. & ! layer above is near its target + (Rcv(k) - Rcv(k-1) > 0.001*(Rcv_tgt(k) - Rcv_tgt(k-1))) ) then +! +! --- water in the deepest inflated layer with significant thickness (kp) is too +! --- light but denser than the layer above, with the layer above near-isopycnal +! --- +! --- split layer into 2 sublayers, one near the desired density +! --- and one exactly matching the T&S properties of layer k-1. +! --- To prevent "runaway" T or S, the result satisfies either +! --- abs(T.k - T.k-1) <= abs(T.k-N - T.k-1) or +! --- abs(S.k - S.k-1) <= abs(S.k-N - S.k-1) where +! --- Rcv.k-1 - Rcv.k-N is at least Rcv_tgt(k-1) - Rcv_tgt(k-2) +! --- It is also limited to a 50% change in layer thickness. + + ka = 1 + do kt=k-2,2,-1 + if ( Rcv(k-1) - Rcv(kt) >= Rcv_tgt(k-1) - Rcv_tgt(k-2) ) then + ka = kt !usually k-2 + exit + endif + enddo + + delsm = abs(saln(ka) - saln(k-1)) + dels = abs(saln(k-1) - saln(k)) + deltm = abs(temp(ka) - temp(k-1)) + delt = abs(temp(k-1) - temp(k)) + + call calculate_density_derivs(temp(k-1), saln(k-1), CS%ref_pressure, abs_dRdT, abs_dRdS, eqn_of_state) + ! Bound deltm and delsm based on the equation of state and density differences between layers. + abs_dRdT = abs(abs_dRdT) ; abs_dRdS = abs(abs_dRdS) + if (abs_dRdT * deltm > Rcv_tgt(k)-Rcv_tgt(k-1)) deltm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdT + if (abs_dRdS * delsm > Rcv_tgt(k)-Rcv_tgt(k-1)) delsm = (Rcv_tgt(k)-Rcv_tgt(k-1)) / abs_dRdS + + qts = 0.0 + if (qts*dels < min(delsm-dels, dels)) qts = min(delsm-dels, dels) / dels + if (qts*delt < min(deltm-delt, delt)) qts = min(deltm-delt, delt) / delt + + ! Note that Rcv_tgt(k) > Rcv(k) > Rcv(k-1), and 0 <= qts <= 1. + ! qhrlx is relaxation coefficient (inverse baroclinic time steps), 0 <= qhrlx <= 1. + ! This takes the minimum of the two estimates. + if ((1.0+qts) * (Rcv_tgt(k)-Rcv(k)) < qts * (Rcv_tgt(k)-Rcv(k-1))) then + q = qhrlx(k) * ((Rcv_tgt(k)-Rcv(k)) / (Rcv_tgt(k)-Rcv(k-1))) + else + q = qhrlx(k) * (qts / (1.0+qts)) ! upper sublayer <= 50% of total + endif + frac_dts = q / (1.0-q) ! 0 <= q <= 0.5, so 0 <= frac_dts <= 1 + + h_hat = q * h_col(k) + h_col(k-1) = h_col(k-1) + h_hat + h_col(k) = h_col(k) - h_hat + + temp(k) = temp(k) + frac_dts * (temp(k) - temp(k-1)) + saln(k) = saln(k) + frac_dts * (saln(k) - saln(k-1)) + call calculate_density(temp(k), saln(k), CS%ref_pressure, Rcv(k), eqn_of_state) + + if ((ntr > 0) .and. (h_hat /= 0.0)) then + ! qtr is the fraction of the new upper layer from the old lower layer. + ! The nonconservative original from Hycom: qtr = h_hat / max(h_hat, h_col(k)) !between 0 and 1 + qtr = h_hat / h_col(k-1) ! Between 0 and 1, noting the h_col(k-1) = h_col(k-1) + h_hat above. + do m=1,ntr + if (trcflg(m) == 2) then !temperature tracer + tracer(k,m) = tracer(k,m) + frac_dts * (tracer(k,m) - tracer(k-1,m)) + else !standard tracer - not split into two sub-layers + tracer(k-1,m) = tracer(k-1,m) + qtr * (tracer(k,m) - tracer(k-1,m)) + endif !trcflg + enddo !m + endif !tracers + endif !too light + +! ! Fill properties of massless or near-massless (thickness < h_thin) layers +! ! This was in the Hycom verion, but it appears to be unnecessary in MOM6. +! do k=kp+1,nk +! ! --- fill thin and massless layers on sea floor with fluid from above +! Rcv(k) = Rcv(k-1) +! do m=1,ntr +! tracer(k,m) = tracer(k-1,m) +! enddo !m +! saln(k) = saln(k-1) +! temp(k) = temp(k-1) +! enddo !k + +end subroutine hybgen_column_unmix + +end module MOM_hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 94d7852851..95a77f503d 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -3,9 +3,11 @@ module MOM_regridding ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert use MOM_file_parser, only : param_file_type, get_param, log_param use MOM_io, only : file_exists, field_exists, field_size, MOM_read_data +use MOM_io, only : vardesc, var_desc, fieldtype, SINGLE_FILE +use MOM_io, only : create_file, MOM_write_field, close_file, file_type use MOM_io, only : verify_variable_units, slasher use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs @@ -19,7 +21,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike @@ -29,6 +31,8 @@ module MOM_regridding use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt +use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid +use MOM_hybgen_regrid, only : write_Hybgen_coord_file implicit none ; private @@ -117,21 +121,24 @@ module MOM_regridding !! If false, use more robust forms of the same remapping expressions. logical :: remap_answers_2018 = .true. + logical :: use_hybgen_unmix = .false. !< If true, use the hybgen unmixing code before remapping + type(zlike_CS), pointer :: zlike_CS => null() !< Control structure for z-like coordinate generator type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator + type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding end type ! The following routines are visible to the outside world public initialize_regridding, end_regridding, regridding_main +public regridding_preadjust_reqs, convective_adjustment public inflate_vanished_layers_old, check_remapping_grid, check_grid_column -public set_regrid_params, get_regrid_size +public set_regrid_params, get_regrid_size, write_regrid_file public uniformResolution, setCoordinateResolution -public build_rho_column public set_target_densities_from_GV, set_target_densities public set_regrid_max_depths, set_regrid_max_thickness public getCoordinateResolution, getCoordinateInterfaces @@ -147,6 +154,7 @@ module MOM_regridding " SIGMA - terrain following coordinates\n"//& " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& + " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" @@ -194,10 +202,10 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings - logical :: tmpLogical, fix_haloclines, set_max, do_sum, main_parameters + logical :: tmpLogical, fix_haloclines, do_sum, main_parameters logical :: coord_is_state_dependent, ierr logical :: default_2018_answers, remap_answers_2018 - real :: filt_len, strat_tol, index_scale, tmpReal, P_Ref + real :: filt_len, strat_tol, tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha @@ -457,6 +465,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! This is a work around to apparently needed to work with the from_Z initialization... ??? if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & + coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then ! Adjust target grid to be consistent with maximum_depth @@ -510,7 +519,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m endif ! initialise coordinate-specific control structure - call initCoord(CS, GV, US, coord_mode) + call initCoord(CS, GV, US, coord_mode, param_file) if (main_parameters .and. coord_is_state_dependent) then call get_param(param_file, mdl, "P_REF", P_Ref, & @@ -535,6 +544,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, min_thickness=0.) endif + CS%use_hybgen_unmix = .false. + if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then + call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & + "If true, use hybgen unmixing code before regridding.", & + default=.false.) + endif + if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then ! Set SLight-specific regridding parameters. call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & @@ -743,6 +759,7 @@ subroutine end_regridding(CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) + if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) deallocate( CS%coordinateResolution ) if (allocated(CS%target_density)) deallocate( CS%target_density ) @@ -753,7 +770,8 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_shelf_h, conv_adjust) +subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, conv_adjust, & + frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between ! the old grid and the new grid. The creation of the new grid can be based @@ -776,22 +794,30 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ type(regridding_CS), intent(in) :: CS !< Regridding control structure 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(inout) :: h !< Current 3D grid obtained after + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after !! the last time step - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamical variables (T, S, ...) - real, dimension(SZI_(G),SZJ_(G), CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface + logical, intent(in ) :: conv_adjust !< If true, regridding_main should do + !! convective adjustment, but because it no + !! longer does convective adjustment this must + !! be false. This argument has been retained to + !! trap inconsistent code, but will eventually + !! be eliminated. real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage - logical, optional, intent(in ) :: conv_adjust !< If true, do convective adjustment + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true + ! Local variables real :: trickGnuCompiler - logical :: use_ice_shelf - logical :: do_convective_adjustment - do_convective_adjustment = .true. - if (present(conv_adjust)) do_convective_adjustment = conv_adjust - - use_ice_shelf = present(frac_shelf_h) + if (conv_adjust) call MOM_error(FATAL, & + "regridding_main: convective adjustment no longer is done inside of regridding_main. "//& + "The code needs to be modified to call regridding_main() with conv_adjust=.false, "//& + "and a call to convective_adjustment added before calling regridding_main() "//& + "if regridding_preadjust_reqs() indicates that this is necessary.") + if (present(PCM_cell)) PCM_cell(:,:,:) = .false. select case ( CS%regridding_scheme ) @@ -805,7 +831,6 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call build_sigma_grid( CS, G, GV, h, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - if (do_convective_adjustment) call convective_adjustment(G, GV, h, tv) call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) @@ -813,6 +838,9 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) + case ( REGRIDDING_HYBGEN ) + call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SLIGHT ) call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -827,11 +855,44 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, frac_ end select ! type of grid #ifdef __DO_SAFETY_CHECKS__ - call check_remapping_grid(G, GV, h, dzInterface,'in regridding_main') + if (CS%nk == GV%ke) call check_remapping_grid(G, GV, h, dzInterface,'in regridding_main') #endif end subroutine regridding_main +!------------------------------------------------------------------------------ +!> This routine returns flags indicating which pre-remapping state adjustments +!! are needed depending on the coordinate mode in use. +subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS) + + ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure + logical, intent(out) :: do_conv_adj !< Convective adjustment should be done + logical, intent(out) :: do_hybgen_unmix !< Hybgen unmixing should be done + type(hybgen_regrid_CS), pointer, & + optional, intent(out) :: hybgen_CS !< Control structure for hybgen regridding for sharing parameters. + + + do_conv_adj = .false. ; do_hybgen_unmix = .false. + select case ( CS%regridding_scheme ) + + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & + REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + do_conv_adj = .false. ; do_hybgen_unmix = .false. + case ( REGRIDDING_RHO ) + do_conv_adj = .true. ; do_hybgen_unmix = .false. + case ( REGRIDDING_HYBGEN ) + do_conv_adj = .false. ; do_hybgen_unmix = CS%use_hybgen_unmix + case default + call MOM_error(FATAL,'MOM_regridding, regridding_preadjust_reqs: '//& + 'Unknown regridding scheme selected!') + end select ! type of grid + + if (present(hybgen_CS) .and. do_hybgen_unmix) hybgen_CS => CS%hybgen_CS + +end subroutine regridding_preadjust_reqs + + !> Calculates h_new from h + delta_k dzInterface subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1086,13 +1147,17 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) 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 thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. ! Local variables - real :: nominalDepth, minThickness, totalThickness, dh ! Depths and thicknesses [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Coordinate interface heights [H ~> m or kg m-2] + real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] +#ifdef __DO_SAFETY_CHECKS__ + real :: dh ! [H ~> m or kg m-2] +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] integer :: i, j, k, nz logical :: ice_shelf @@ -1103,7 +1168,10 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & !$OMP ice_shelf,minThickness) & !$OMP private(nominalDepth,totalThickness, & -!$OMP zNew,dh,zOld) +#ifdef __DO_SAFETY_CHECKS__ +!$OMP dh, & +#endif +!$OMP zNew,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1144,17 +1212,23 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness - write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz - do k=1,nz+1 + write(0,*) 'dzInterface(1) = ', dzInterface(i,j,1), epsilon(dh), nz, CS%nk + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,nz + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),CS%coordinateResolution(k) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_zstar_grid(): top surface has moved!!!' ) endif @@ -1183,14 +1257,18 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) 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 thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] ! Local variables integer :: i, j, k integer :: nz - real :: nominalDepth, totalThickness, dh - real, dimension(SZK_(GV)+1) :: zOld, zNew + real :: nominalDepth, totalThickness +#ifdef __DO_SAFETY_CHECKS__ + real :: dh +#endif + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] nz = GV%ke @@ -1227,12 +1305,18 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo - do k=1,CS%nk + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo + do k=1,min(nz,CS%nk) write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k,0.0,zNew(k)-zNew(k+1),totalThickness*CS%coordinateResolution(k),CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_sigma_grid: top surface has moved!!!' ) endif @@ -1266,22 +1350,23 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel !------------------------------------------------------------------------------ ! Arguments + type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice !! shelf coverage [nondim] ! Local variables - integer :: nz + integer :: nz ! The number of layers in the input grid integer :: i, j, k real :: nominalDepth ! Depth of the bottom of the ocean, positive downward [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: zOld, zNew ! Old and new interface heights [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ @@ -1355,7 +1440,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - do k = 2,nz + do k=2,CS%nk if (zNew(k) > zOld(1)) then write(0,*) 'zOld=',zOld write(0,*) 'zNew=',zNew @@ -1380,12 +1465,18 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz - do k=1,nz+1 + do k=1,min(nz,CS%nk)+1 write(0,*) k,zOld(k),zNew(k) enddo + do k=min(nz,CS%nk)+2,CS%nk+1 + write(0,*) k,zOld(nz+1),zNew(k) + enddo do k=1,nz write(0,*) k,h(i,j,k),zNew(k)-zNew(k+1) enddo + do k=min(nz,CS%nk)+1,CS%nk + write(0,*) k, 0.0, zNew(k)-zNew(k+1), CS%coordinateResolution(k) + enddo call MOM_error( FATAL, & 'MOM_regridding, build_rho_grid: top surface has moved!!!' ) endif @@ -1416,12 +1507,12 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she !! coverage [nondim] ! Local variables - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] integer :: i, j, k, nki - real :: depth, nominalDepth + real :: nominalDepth real :: h_neglect, h_neglect_edge real :: z_top_col, totalThickness logical :: ice_shelf @@ -1496,10 +1587,10 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface depth + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure ! local variables integer :: i, j, k, nz ! indices and dimension lengths @@ -1512,6 +1603,9 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) nz = GV%ke + call assert((GV%ke == CS%nk), "build_grid_adaptive is only written to work "//& + "with the same number of input and target layers.") + ! position surface at z = 0. zInt(:,:,1) = 0. @@ -1562,13 +1656,13 @@ subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: dzInterface !< Changes in interface position type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position - real, dimension(SZK_(GV)+1) :: z_col ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: z_col_new ! Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure [R L2 T-2 ~> Pa] + real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] + real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] ! Local variables real :: depth ! Depth of the ocean relative to the mean sea surface height in thickness units [H ~> m or kg m-2] @@ -1585,8 +1679,10 @@ subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) nz = GV%ke - if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_SLight : "//& - "Target densities must be set before build_grid_SLight is called.") + call assert((GV%ke == CS%nk), "build_grid_SLight is only written to work "//& + "with the same number of input and target layers.") + call assert(CS%target_density_set, "build_grid_SLight : "//& + "Target densities must be set before build_grid_SLight is called.") ! Build grid based on target interface densities do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 @@ -1691,13 +1787,13 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) !------------------------------------------------------------------------------ ! Arguments - 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 !< Original layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)+1), intent(inout) :: dzInterface !< The change in interface - !! depth [H ~> m or kg m-2] - real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] - type(regridding_CS), intent(in) :: CS !< Regridding control structure + 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 !< Original layer thicknesses [H ~> m or kg m-2] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface + !! depth [H ~> m or kg m-2] + real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] ! Local variables integer :: i, j, k @@ -1840,14 +1936,17 @@ subroutine convective_adjustment(G, GV, h, tv) !------------------------------------------------------------------------------ ! Local variables - integer :: i, j, k - real :: T0, T1 ! temperatures - real :: S0, S1 ! salinities - real :: r0, r1 ! densities - real :: h0, h1 + real :: T0, T1 ! temperatures of two layers [degC] + real :: S0, S1 ! salinities of two layers [ppt] + real :: r0, r1 ! densities of two layers [R ~> kg m-3] + real :: h0, h1 ! Layer thicknesses [H ~> m or kg m-2] + real, dimension(GV%ke) :: p_col ! A column of zero pressures [R L2 T-2 ~> Pa] + real, dimension(GV%ke) :: densities ! Densities in the column [R ~> kg m-3] logical :: stratified - real, dimension(GV%ke) :: p_col, densities + integer :: i, j, k + !### Doing convective adjustment based on potential densities with zero pressure seems + ! questionable, although it does avoid ambiguous sorting. -RWH p_col(:) = 0. ! Loop on columns @@ -1876,6 +1975,8 @@ subroutine convective_adjustment(G, GV, h, tv) call calculate_density( tv%T(i,j,k), tv%S(i,j,k), p_col(k), densities(k), tv%eqn_of_state) call calculate_density( tv%T(i,j,k+1), tv%S(i,j,k+1), p_col(k+1), & densities(k+1), tv%eqn_of_state ) + ! Because p_col is has uniform values, these calculate_density calls are equivalent to + ! densities(k) = r1 ; densities(k+1) = r0 stratified = .false. endif enddo ! k @@ -1911,8 +2012,8 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_SIGMA_SHELF_ZSTAR, & - REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) case ( REGRIDDING_RHO ) @@ -1931,13 +2032,14 @@ end function uniformResolution !> Initialize the coordinate resolutions by calling the appropriate initialization !! routine for the specified coordinate mode. -subroutine initCoord(CS, GV, US, coord_mode) +subroutine initCoord(CS, GV, US, coord_mode, param_file) type(regridding_CS), intent(inout) :: CS !< Regridding control structure character(len=*), intent(in) :: coord_mode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. 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 select case (coordinateMode(coord_mode)) case (REGRIDDING_ZSTAR) @@ -1951,6 +2053,8 @@ subroutine initCoord(CS, GV, US, coord_mode) case (REGRIDDING_HYCOM1) call init_coord_hycom(CS%hycom_CS, CS%nk, CS%coordinateResolution, CS%target_density, & CS%interp_CS) + case (REGRIDDING_HYBGEN) + call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) case (REGRIDDING_SLIGHT) call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & CS%interp_CS, GV%m_to_H) @@ -2079,6 +2183,42 @@ subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) end subroutine set_regrid_max_thickness +!> Write the vertical coordinate information into a file. +!! This subroutine writes out a file containing any available data related +!! to the vertical grid used by the MOM ocean model when in ALE mode. +subroutine write_regrid_file( CS, GV, filepath ) + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + character(len=*), intent(in) :: filepath !< The full path to the file to write + + type(vardesc) :: vars(2) + type(fieldtype) :: fields(2) + type(file_type) :: IO_handle ! The I/O handle of the fileset + real :: ds(GV%ke), dsi(GV%ke+1) + + if (CS%regridding_scheme == REGRIDDING_HYBGEN) then + call write_Hybgen_coord_file(GV, CS%hybgen_CS, filepath) + return + endif + + ds(:) = CS%coord_scale * CS%coordinateResolution(:) + dsi(1) = 0.5*ds(1) + dsi(2:GV%ke) = 0.5*( ds(1:GV%ke-1) + ds(2:GV%ke) ) + dsi(GV%ke+1) = 0.5*ds(GV%ke) + + vars(1) = var_desc('ds', getCoordinateUnits( CS ), & + 'Layer Coordinate Thickness', '1', 'L', '1') + vars(2) = var_desc('ds_interface', getCoordinateUnits( CS ), & + 'Layer Center Coordinate Separation', '1', 'i', '1') + + call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call MOM_write_field(IO_handle, fields(1), ds) + call MOM_write_field(IO_handle, fields(2), dsi) + call close_file(IO_handle) + +end subroutine write_regrid_file + + !------------------------------------------------------------------------------ !> Query the fixed resolution data function getCoordinateResolution( CS, undo_scaling ) @@ -2149,7 +2289,8 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) getCoordinateUnits = 'meter/fraction' @@ -2187,6 +2328,8 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'coordinate' case ( REGRIDDING_HYCOM1 ) getCoordinateShortName = 'z-rho' + case ( REGRIDDING_HYBGEN ) + getCoordinateShortName = 'hybrid' case ( REGRIDDING_SLIGHT ) getCoordinateShortName = 's-rho' case ( REGRIDDING_ADAPTIVE ) @@ -2281,6 +2424,8 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri case (REGRIDDING_HYCOM1) if (associated(CS%hycom_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) + case (REGRIDDING_HYBGEN) + ! Do nothing for now. case (REGRIDDING_SLIGHT) if (present(min_thickness)) call set_slight_params(CS%slight_CS, min_thickness=min_thickness) if (present(dz_min_surface)) call set_slight_params(CS%slight_CS, dz_ml_min=dz_min_surface) @@ -2349,7 +2494,8 @@ function getStaticThickness( CS, SSH, depth ) real :: z, dz select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & + REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 1b3c5884de..50e1085cf6 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -13,12 +13,12 @@ module MOM_remapping use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 +use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs + use MOM_io, only : stdout, stderr implicit none ; private -#include - !> Container for remapping parameters type, public :: remapping_CS private @@ -46,11 +46,14 @@ module MOM_remapping ! The following are private parameter constants integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme -integer, parameter :: REMAPPING_PLM = 1 !< O(h^2) remapping scheme -integer, parameter :: REMAPPING_PPM_H4 = 2 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PPM_IH4 = 3 !< O(h^3) remapping scheme -integer, parameter :: REMAPPING_PQM_IH4IH3 = 4 !< O(h^4) remapping scheme -integer, parameter :: REMAPPING_PQM_IH6IH5 = 5 !< O(h^5) remapping scheme +integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_WENO_HYBGEN= 7 !< O(h^3) remapping scheme +integer, parameter :: REMAPPING_PQM_IH4IH3 = 8 !< O(h^4) remapping scheme +integer, parameter :: REMAPPING_PQM_IH6IH5 = 9 !< O(h^5) remapping scheme integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method @@ -60,11 +63,14 @@ module MOM_remapping character(len=40) :: mdl = "MOM_remapping" !< This module's name. !> Documentation for external callers -character(len=256), public :: remappingSchemesDoc = & +character(len=360), public :: remappingSchemesDoc = & "PCM (1st-order accurate)\n"//& "PLM (2nd-order accurate)\n"//& + "PLM_HYBGEN (2nd-order accurate)\n"//& "PPM_H4 (3rd-order accurate)\n"//& "PPM_IH4 (3rd-order accurate)\n"//& + "PPM_HYBGEN (3rd-order accurate)\n"//& + "WENO_HYBGEN (3rd-order accurate)\n"//& "PQM_IH4IH3 (4th-order accurate)\n"//& "PQM_IH6IH5 (5th-order accurate)\n" character(len=3), public :: remappingDefaultScheme = "PLM" !< Default remapping method @@ -185,41 +191,48 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) end function isPosSumErrSignificant !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. -subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) +subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid - real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] + real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h0. + !! in the same units as h0 [H] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value - !! calculations in the same units as h0. + !! calculations in the same units as h0 [H] + logical, dimension(n0), optional, intent(in) :: PCM_cell !< If present, use PCM remapping for + !! cells in the source grid where this is true. + ! Local variables integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial + real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] + real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] + real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] + real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] + real :: uh_err ! Difference in the total amounts on the two grids [H A] + real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] integer :: k - real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err - real :: hNeglect, hNeglect_edge hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & - hNeglect, hNeglect_edge ) + hNeglect, hNeglect_edge, PCM_cell ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) - + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell, u1, uh_err ) + CS%force_bounds_in_subcell, u1, uh_err ) if (CS%check_remapping) then ! Check errors and bounds @@ -283,7 +296,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k - real :: eps, h0tot, h0err, h1tot, h1err + real :: h0tot, h0err, h1tot, h1err real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real, dimension(n1) :: h1 !< Cell widths on target grid real :: hNeglect, hNeglect_edge @@ -306,7 +319,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed endif enddo call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & - CS%force_bounds_in_subcell,u1, uh_err ) + CS%force_bounds_in_subcell, u1, uh_err ) ! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) ! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) @@ -353,7 +366,7 @@ end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & - h_neglect_edge ) + h_neglect_edge, PCM_cell ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid @@ -369,10 +382,12 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value !! calculations in the same units as h0. + logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for + !! cells from the source grid where this is true. + ! Local variables integer :: local_remapping_scheme - integer :: remapping_scheme !< Remapping scheme - logical :: boundary_extrapolation !< Extrapolate at boundaries if true + integer :: k, n ! Reset polynomial ppoly_r_E(:,:) = 0.0 @@ -398,6 +413,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) endif iMethod = INTEGRATION_PLM + case ( REMAPPING_PLM_HYBGEN ) + call hybgen_PLM_coefs(u0, h0, ppoly_r_coefs(:,2), n0, 1, h_neglect) + do k=1,n0 + ppoly_r_E(k,1) = u0(k) - 0.5 * ppoly_r_coefs(k,2) ! Left edge value of cell k + ppoly_r_E(k,2) = u0(k) + 0.5 * ppoly_r_coefs(k,2) ! Right edge value of cell k + ppoly_r_coefs(k,1) = ppoly_r_E(k,1) + enddo + if ( CS%boundary_extrapolation ) & + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=CS%answers_2018 ) @@ -412,6 +437,18 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) endif iMethod = INTEGRATION_PPM + case ( REMAPPING_PPM_HYBGEN ) + call hybgen_PPM_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=.false. ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM + case ( REMAPPING_WENO_HYBGEN ) + call hybgen_weno_coefs(u0, h0, ppoly_r_E, n0, 1, h_neglect) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answers_2018=.false. ) + if ( CS%boundary_extrapolation ) & + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answers_2018=CS%answers_2018 ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect, answers_2018=CS%answers_2018 ) @@ -437,6 +474,16 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & 'The selected remapping method is invalid' ) end select + if (present(PCM_cell)) then + ! Change the coefficients to those for the piecewise constant method in indicated cells. + do k=1,n0 ; if (PCM_cell(k)) then + ppoly_r_coefs(k,1) = u0(k) + ppoly_r_E(k,1:2) = u0(k) + ppoly_r_S(k,1:2) = 0.0 + do n=2,CS%degree+1 ; ppoly_r_coefs(k,n) = 0.0 ; enddo + endif ; enddo + endif + end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds @@ -465,13 +512,13 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_l, u_c) u_max = max(u_l, u_c) if (ppoly_r_E(i0,1) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge undershoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,1) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Left edge overshoot at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'edge=',ppoly_r_E(i0,1),'err=',ppoly_r_E(i0,1)-u_max problem_detected = .true. endif endif @@ -479,27 +526,27 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & u_min = min(u_c, u_r) u_max = max(u_c, u_r) if (ppoly_r_E(i0,2) < u_min) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge undershoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_min problem_detected = .true. endif if (ppoly_r_E(i0,2) > u_max) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & - 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Right edge overshoot at',i0,'u(i0)=',u_c,'u(i0+1)=',u_r, & + 'edge=',ppoly_r_E(i0,2),'err=',ppoly_r_E(i0,2)-u_max problem_detected = .true. endif endif if (i0 > 1) then if ( (u_c-u_l)*(ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2)) < 0.) then - write(0,'(a,i4,5(x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & - 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) - write(0,'(5(a,1pe24.16,x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) + write(0,'(a,i4,5(1x,a,1pe24.16))') 'Non-monotonic edges at',i0,'u(i0-1)=',u_l,'u(i0)=',u_c, & + 'right edge=',ppoly_r_E(i0-1,2),'left edge=',ppoly_r_E(i0,1) + write(0,'(5(a,1pe24.16,1x))') 'u(i0)-u(i0-1)',u_c-u_l,'edge diff=',ppoly_r_E(i0,1)-ppoly_r_E(i0-1,2) problem_detected = .true. endif endif if (problem_detected) then write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) - write(0,'(3(a,1pe24.16,x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r + write(0,'(3(a,1pe24.16,1x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) @@ -1580,12 +1627,21 @@ subroutine setReconstructionType(string,CS) case ("PLM") CS%remapping_scheme = REMAPPING_PLM degree = 1 + case ("PLM_HYBGEN") + CS%remapping_scheme = REMAPPING_PLM_HYBGEN + degree = 1 case ("PPM_H4") CS%remapping_scheme = REMAPPING_PPM_H4 degree = 2 case ("PPM_IH4") CS%remapping_scheme = REMAPPING_PPM_IH4 degree = 2 + case ("PPM_HYBGEN") + CS%remapping_scheme = REMAPPING_PPM_HYBGEN + degree = 2 + case ("WENO_HYBGEN") + CS%remapping_scheme = REMAPPING_WENO_HYBGEN + degree = 2 case ("PQM_IH4IH3") CS%remapping_scheme = REMAPPING_PQM_IH4IH3 degree = 4 @@ -1900,7 +1956,7 @@ logical function test_answer(verbose, n, u, u_true, label, tol) if (abs(u(k) - u_true(k)) > tolerance) test_answer = .true. enddo if (test_answer .or. verbose) then - write(stdout,'(a4,2a24,x,a)') 'k','Calculated value','Correct value',label + write(stdout,'(a4,2a24,1x,a)') 'k','Calculated value','Correct value',label do k = 1, n if (abs(u(k) - u_true(k)) > tolerance) then write(stdout,'(i4,1p2e24.16,a,1pe24.16,a)') k,u(k),u_true(k),' err=',u(k)-u_true(k),' < wrong' diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index d0f620e4a8..9defeb9215 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -197,11 +197,9 @@ subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) ! Local variables integer :: k ! loop index - real :: u_l, u_c, u_r ! left, center and right cell averages - real :: h_l, h_c, h_r, h_cn ! left, center and right cell widths + real :: u_l, u_r ! left and right cell averages real :: slope ! retained PLM slope - real :: a, b ! auxiliary variables - real :: u_min, u_max, e_l, e_r, edge + real :: e_r, edge real :: almost_one real, dimension(N) :: slp, mslp real :: hNeglect diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index fe3864fc7a..e5b33103ef 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -154,7 +154,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! TODO: this needs to be adjusted to account for vanished layers near topography ! up (j-1) - if (G%mask2dT(i,j-1) > 0.) then + if (G%mask2dT(i,j-1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j-1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j-1,2:nz)), & @@ -166,7 +166,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j-1,2:nz) - sInt(i,j,2:nz))) endif ! down (j+1) - if (G%mask2dT(i,j+1) > 0.) then + if (G%mask2dT(i,j+1) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i,j+1,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i,j+1,2:nz)), & @@ -178,7 +178,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i,j+1,2:nz) - sInt(i,j,2:nz))) endif ! left (i-1) - if (G%mask2dT(i-1,j) > 0.) then + if (G%mask2dT(i-1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i-1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i-1,j,2:nz)), & @@ -190,7 +190,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex beta(2:nz) * (sInt(i-1,j,2:nz) - sInt(i,j,2:nz))) endif ! right (i+1) - if (G%mask2dT(i+1,j) > 0.) then + if (G%mask2dT(i+1,j) > 0.0) then call calculate_density_derivs( & 0.5 * (tInt(i,j,2:nz) + tInt(i+1,j,2:nz)), & 0.5 * (sInt(i,j,2:nz) + sInt(i+1,j,2:nz)), & diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 23a390456e..66c78d7c7a 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -235,13 +235,11 @@ subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. - real :: k2_used, k2here, dz_sum, z_max - integer :: k2 real :: h_tr, b_denom_1, b1, d1 ! Temporary variables used by the tridiagonal solver. real, dimension(nz) :: c1 ! Temporary variables used by the tridiagonal solver. integer :: kur1, kur2 ! The indicies at the top and bottom of an unreliable region. integer :: kur_ss ! The index to start with in the search for the next unstable region. - integer :: i, j, k, nkml + integer :: k, nkml maximum_depths_set = allocated(CS%max_interface_depths) maximum_h_set = allocated(CS%max_layer_thickness) diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 7e8edea344..9fe638dd5b 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -21,6 +21,7 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier +integer, parameter :: REGRIDDING_HYBGEN = 10 !< Hybgen coordinates identifier character(len=*), parameter :: REGRIDDING_LAYER_STRING = "LAYER" !< Layer string character(len=*), parameter :: REGRIDDING_ZSTAR_STRING_OLD = "Z*" !< z* string (legacy name) @@ -29,6 +30,7 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_SIGMA_STRING = "SIGMA" !< Sigma string character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string +character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string @@ -60,6 +62,7 @@ function coordinateMode(string) case (trim(REGRIDDING_RHO_STRING)); coordinateMode = REGRIDDING_RHO case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 + case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR @@ -81,6 +84,7 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_RHO); coordinateUnitsI = "kg m^-3" case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" + case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& @@ -116,6 +120,7 @@ logical function state_dependent_int(mode) case (REGRIDDING_RHO); state_dependent_int = .true. case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. + case (REGRIDDING_HYBGEN); state_dependent_int = .true. case (REGRIDDING_SLIGHT); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 2baac56599..a972fc3444 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -229,7 +229,6 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables real :: h0, h1, h2, h3 ! temporary thicknesses [H] - real :: h_sum ! A sum of adjacent thicknesses [H] real :: h_min ! A minimal cell width [H] real :: f1, f2, f3 ! auxiliary variables with various units real :: et1, et2, et3 ! terms the expresson for edge values [A H] @@ -240,7 +239,7 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Difference of successive values of x [H] real, dimension(4,4) :: A ! values near the boundaries real, dimension(4) :: B, C real :: hNeglect ! A negligible thickness in the same units as h. @@ -394,9 +393,8 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) ! Local variables integer :: i, j ! loop indexes - real :: h0, h1, h2 ! cell widths [H] + real :: h0, h1 ! cell widths [H] real :: h_min ! A minimal cell width [H] - real :: h_sum ! A sum of adjacent thicknesses [H] real :: h0_2, h1_2, h0h1 real :: h0ph1_2, h0ph1_4 real :: alpha, beta ! stencil coefficients [nondim] @@ -407,7 +405,7 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answers_2018 ) real, parameter :: C1_3 = 1.0 / 3.0 real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] @@ -569,7 +567,6 @@ subroutine end_value_h4(dz, u, Csys) real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] real, parameter :: C1_3 = 1.0 / 3.0 - integer :: i, j, k ! These are only used for code verification ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. @@ -706,7 +703,6 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real :: h0, h1 ! cell widths [H or nondim] real :: h0_2, h1_2, h0h1 ! products of cell widths [H2 or nondim] real :: h0_3, h1_3 ! products of three cell widths [H3 or nondim] - real :: h_min ! A minimal cell width [H] real :: d ! A temporary variable [H3] real :: I_d ! A temporary variable [nondim] real :: I_h ! Inverses of thicknesses [H-1] @@ -716,7 +712,7 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answers_201 real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx, xavg ! Differences and averages of successive values of x [H] + real :: dx ! Differences and averages of successive values of x [H] real, dimension(4,4) :: Asys ! matrix used to find boundary conditions real, dimension(4) :: Bsys, Csys real, dimension(3) :: Dsys @@ -927,7 +923,7 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answers_201 tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) real :: h_Min_Frac = 1.0e-4 - integer :: i, j, k ! loop indexes + integer :: i, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -1162,7 +1158,7 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answers_2018 ) tri_u, & ! trid. system (upper diagonal) tri_b, & ! trid. system (unknowns vector) tri_x ! trid. system (rhs) - integer :: i, j, k ! loop indexes + integer :: i, k ! loop indexes hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 87019d46cf..21773774f6 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -283,7 +283,6 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. ! Local variables - logical :: use_2018_answers ! If true use older, less acccurate expressions. integer :: k ! loop index real :: t ! current interface target density diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 50bd7f984d..b7cc3b5402 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -119,7 +119,6 @@ subroutine linear_solver( N, A, R, X ) real :: factor ! The factor that eliminates the leading nonzero element in a row. real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] real :: swap - logical :: found_pivot ! If true, a pivot has been found integer :: i, j, k ! Loop on rows to transform the problem into multiplication by an upper-right matrix. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c36c0545e1..c4f3d40343 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -56,7 +56,8 @@ module MOM use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS -use MOM_coord_initialization, only : MOM_initialize_coord +use MOM_check_scaling, only : check_MOM6_scaling_factors +use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS @@ -507,10 +508,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! if it is not to be calculated anew [T ~> s]. real :: rel_time = 0.0 ! relative time since start of this call [T ~> s]. - logical :: calc_dtbt ! Indicates whether the dynamically adjusted - ! barotropic time step needs to be updated. logical :: do_advection ! If true, it is time to advect tracers. - logical :: do_calc_bbl ! If true, calculate the boundary layer properties. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. @@ -532,7 +530,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS p_surf => NULL() ! A pointer to the ocean surface pressure [R L2 T-2 ~> Pa]. real :: I_wt_ssh ! The inverse of the time weights [T-1 ~> s-1] - type(time_type) :: Time_local, end_time_thermo, Time_temp + type(time_type) :: Time_local, end_time_thermo type(group_pass_type) :: pass_tau_ustar_psurf logical :: showCallTree @@ -590,7 +588,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call homogenize_mech_forcing(forces, G, US, GV%Rho0, CS%update_ustar) ! Note the following computes the mean ustar as the mean of ustar rather than ! ustar of the mean of tau. - call homogenize_forcing(fluxes, G) + call homogenize_forcing(fluxes, G, GV, US) if (CS%update_ustar) then ! These calls corrects the ustar values call copy_common_forcing_fields(forces, fluxes, G) @@ -965,7 +963,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (cycle_end) then if (CS%rotate_index) then allocate(sfc_state_diag) - call rotate_surface_state(sfc_state, G_in, sfc_state_diag, G, turns) + call rotate_surface_state(sfc_state, sfc_state_diag, G, turns) else sfc_state_diag => sfc_state endif @@ -1049,7 +1047,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & ! barotropic time step needs to be updated. logical :: showCallTree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights @@ -1330,7 +1328,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. integer :: halo_sz ! The size of a halo where data must be valid. - integer :: i, j, k, is, ie, js, je, nz + integer :: is, ie, js, je, nz real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%G)+1) :: eta_por ! layer interface heights !! for porous topo. [Z ~> m or 1/eta_to_m] @@ -1531,11 +1529,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS real :: dt_offline ! The offline timestep for advection [T ~> s] real :: dt_offline_vertical ! The offline timestep for vertical fluxes and remapping [T ~> s] logical :: skip_diffusion - integer :: id_eta_diff_end type(time_type), pointer :: accumulated_time => NULL() type(time_type), pointer :: vertical_time => NULL() - integer :: i,j,k integer :: is, ie, js, je, isd, ied, jsd, jed ! 3D pointers @@ -1761,20 +1757,16 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This include declares and sets the variable "version". # include "version_variable.h" - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB real :: dtbt ! If negative, this specifies the barotropic timestep as a fraction ! of the maximum stable value [nondim]. real, allocatable, dimension(:,:) :: eta ! free surface height or column mass [H ~> m or kg m-2] - real, allocatable, dimension(:,:) :: area_shelf_in ! area occupied by ice shelf [L2 ~> m2] -! real, dimension(:,:), pointer :: shelf_area => NULL() - type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. - logical :: ensemble_ocean ! If true, perform an ensemble gather at the end of step_MOM logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. @@ -1815,12 +1807,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] real :: conv2salt ! A conversion factor for salt fluxes [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: RL2_T2_rescale, Z_rescale, QRZ_rescale ! Unit conversion factors - character(len=48) :: flux_units, S_flux_units + character(len=48) :: S_flux_units type(vardesc) :: vd_T, vd_S ! Structures describing temperature and salinity variables. type(time_type) :: Start_time type(ocean_internal_state) :: MOM_internal_state - character(len=200) :: area_varname, ice_shelf_file, inputdir, filename CS%Time => Time @@ -1907,7 +1898,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "If False, T/S are registered for advection. "//& "This is intended only to be used in offline tracer mode "//& "and is by default false in that case.", & - do_not_log = .true., default=.true. ) + do_not_log=.true., default=.true.) if (present(offline_tracer_mode)) then ! Only read this parameter in enabled modes call get_param(param_file, "MOM", "OFFLINE_TRACER_MODE", CS%offline_tracer_mode, & "If true, barotropic and baroclinic dynamics, thermodynamics "//& @@ -2285,6 +2276,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif ! dG_in is retained for now so that it can be used with write_ocean_geometry_file() below. + if (is_root_PE()) call check_MOM6_scaling_factors(CS%GV, US) + call callTree_waypoint("grids initialized (initialize_MOM)") call MOM_timing_init(CS) @@ -2419,7 +2412,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call restart_init(param_file, restart_CSp) call set_restart_fields(GV, US, param_file, CS, restart_CSp) if (CS%split) then - call register_restarts_dyn_split_RK2(HI, GV, param_file, & + call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) elseif (CS%use_RK2) then call register_restarts_dyn_unsplit_RK2(HI, GV, param_file, & @@ -2434,9 +2427,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call call_tracer_register(HI, GV, US, param_file, CS%tracer_flow_CSp, & CS%tracer_Reg, restart_CSp) - call MEKE_alloc_register_restart(HI, param_file, CS%MEKE, restart_CSp) - call set_visc_register_restarts(HI, GV, param_file, CS%visc, restart_CSp) - call mixedlayer_restrat_register_restarts(HI, param_file, & + call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) + call set_visc_register_restarts(HI, GV, US, param_file, CS%visc, restart_CSp) + call mixedlayer_restrat_register_restarts(HI, GV, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then @@ -2465,7 +2458,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This needs the number of tracers and to have called any code that sets whether ! reservoirs are used. - call open_boundary_register_restarts(HI, GV, CS%OBC, CS%tracer_Reg, & + call open_boundary_register_restarts(HI, GV, US, CS%OBC, CS%tracer_Reg, & param_file, restart_CSp, use_temperature) endif @@ -2481,8 +2474,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Initialize dynamically evolving fields, perhaps from restart files. call cpu_clock_begin(id_clock_MOM_init) - call MOM_initialize_coord(GV, US, param_file, write_geom_files, & - dirs%output_directory, CS%tv, G%max_depth) + call MOM_initialize_coord(GV, US, param_file, CS%tv, G%max_depth) call callTree_waypoint("returned from MOM_initialize_coord() (initialize_MOM)") if (CS%use_ALE_algorithm) then @@ -2645,8 +2637,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! \todo This block exists for legacy reasons and we should phase it out of ! all examples. !### if (CS%debug) then - call uvchksum("Pre ALE adjust init cond [uv]", & - CS%u, CS%v, G%HI, haloshift=1) + call uvchksum("Pre ALE adjust init cond [uv]", CS%u, CS%v, G%HI, haloshift=1) call hchksum(CS%h,"Pre ALE adjust init cond h", G%HI, haloshift=1, scale=GV%H_to_m) endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") @@ -2709,19 +2700,21 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! must be defined. call set_masks_for_axes(G, diag) - ! Diagnose static fields AND associate areas/volumes with axes - call write_static_fields(G, GV, US, CS%tv, CS%diag) - call callTree_waypoint("static fields written (initialize_MOM)") - ! Register the volume cell measure (must be one of first diagnostics) call register_cell_measure(G, CS%diag, Time) call cpu_clock_begin(id_clock_MOM_init) + ! Diagnose static fields AND associate areas/volumes with axes + call write_static_fields(G, GV, US, CS%tv, CS%diag) + call callTree_waypoint("static fields written (initialize_MOM)") + if (CS%use_ALE_algorithm) then call ALE_writeCoordinateFile( CS%ALE_CSp, GV, dirs%output_directory ) + call callTree_waypoint("ALE initialized (initialize_MOM)") + elseif (write_geom_files) then + call write_vertgrid_file(GV, US, param_file, dirs%output_directory) endif call cpu_clock_end(id_clock_MOM_init) - call callTree_waypoint("ALE initialized (initialize_MOM)") CS%useMEKE = MEKE_init(Time, G, US, param_file, diag, CS%MEKE_CSp, CS%MEKE, restart_CSp) @@ -2862,11 +2855,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_frazil) then if (query_initialized(CS%tv%frazil, "frazil", restart_CSp)) then ! Test whether the dimensional rescaling has changed for heat content. - if ((US%kg_m3_to_R_restart*US%m_to_Z_restart*US%J_kg_to_Q_restart /= 0.0) .and. & - ((US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) /= & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart)) ) then - QRZ_rescale = (US%J_kg_to_Q*US%kg_m3_to_R*US%m_to_Z) / & - (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) + if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 0.0) .and. & + (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart /= 1.0) ) then + QRZ_rescale = 1.0 / (US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart) do j=js,je ; do i=is,ie CS%tv%frazil(i,j) = QRZ_rescale * CS%tv%frazil(i,j) enddo ; enddo @@ -2882,10 +2873,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (CS%p_surf_prev_set) then ! Test whether the dimensional rescaling has changed for pressure. if ((US%kg_m3_to_R_restart*US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - ((US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) /= & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2)) ) then - RL2_T2_rescale = (US%kg_m3_to_R*(US%m_to_L*US%s_to_T_restart)**2) / & - (US%kg_m3_to_R_restart*(US%m_to_L_restart*US%s_to_T)**2) + (US%s_to_T_restart**2 /= US%kg_m3_to_R_restart * US%m_to_L_restart**2) ) then + RL2_T2_rescale = US%s_to_T_restart**2 / (US%kg_m3_to_R_restart*US%m_to_L_restart**2) do j=js,je ; do i=is,ie CS%p_surf_prev(i,j) = RL2_T2_rescale * CS%p_surf_prev(i,j) enddo ; enddo @@ -2898,8 +2887,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (use_ice_shelf .and. associated(CS%Hml)) then if (query_initialized(CS%Hml, "hML", restart_CSp)) then ! Test whether the dimensional rescaling has changed for depths. - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=js,je ; do i=is,ie CS%Hml(i,j) = Z_rescale * CS%Hml(i,j) enddo ; enddo @@ -2908,8 +2897,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (query_initialized(CS%ave_ssh_ibc,"ave_ssh",restart_CSp)) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z /= US%m_to_Z_restart) ) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0) ) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=js,je ; do i=is,ie CS%ave_ssh_ibc(i,j) = Z_rescale * CS%ave_ssh_ibc(i,j) enddo ; enddo @@ -2964,7 +2953,6 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! various unit conversion factors type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() real, allocatable :: z_interface(:,:,:) ! Interface heights [m] - type(vardesc) :: vd call cpu_clock_begin(id_clock_init) call callTree_enter("finish_MOM_initialization()") @@ -2973,8 +2961,8 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) G => CS%G ; GV => CS%GV ; US => CS%US !### Move to initialize_MOM? - call fix_restart_scaling(GV) - call fix_restart_unit_scaling(US) + call fix_restart_scaling(GV, unscaled=.true.) + call fix_restart_unit_scaling(US, unscaled=.true.) if (CS%use_particles) then @@ -3087,9 +3075,6 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') - v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') - if (associated(CS%tv%T)) & call register_restart_field(CS%tv%T, "Temp", .true., restart_CSp, & "Potential Temperature", "degC") @@ -3098,28 +3083,31 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Salinity", "PPT") call register_restart_field(CS%h, "h", .true., restart_CSp, & - "Layer Thickness", thickness_units) + "Layer Thickness", thickness_units, conversion=GV%H_to_MKS) - call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp) + u_desc = var_desc("u", "m s-1", "Zonal velocity", hor_grid='Cu') + v_desc = var_desc("v", "m s-1", "Meridional velocity", hor_grid='Cv') + call register_restart_pair(CS%u, CS%v, u_desc, v_desc, .true., restart_CSp, conversion=US%L_T_to_m_s) if (associated(CS%tv%frazil)) & call register_restart_field(CS%tv%frazil, "frazil", .false., restart_CSp, & - "Frazil heat flux into ocean", "J m-2") + "Frazil heat flux into ocean", & + "J m-2", conversion=US%Q_to_J_kg*US%RZ_to_kg_m2) if (CS%interp_p_surf) then call register_restart_field(CS%p_surf_prev, "p_surf_prev", .false., restart_CSp, & - "Previous ocean surface pressure", "Pa") + "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) endif call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & - "Time average sea surface height", "meter") + "Time average sea surface height", "meter", conversion=US%Z_to_m) ! hML is needed when using the ice shelf module call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter") + "Mixed layer thickness", "meter", conversion=US%Z_to_m) endif ! Register scalar unit conversion factors. @@ -3553,7 +3541,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ig = i + G%HI%idg_offset ! Global i-index jg = j + G%HI%jdg_offset ! Global j-index if (use_temperature) then - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),8(a,es11.4,x))') & + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),8(a,es11.4,1x))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(ig), 'y=',G%gridLatT(jg), & @@ -3562,7 +3550,7 @@ subroutine extract_surface_state(CS, sfc_state_in) 'U-=',US%L_T_to_m_s*sfc_state%u(I-1,j), 'U+=',US%L_T_to_m_s*sfc_state%u(I,j), & 'V-=',US%L_T_to_m_s*sfc_state%v(i,J-1), 'V+=',US%L_T_to_m_s*sfc_state%v(i,J) else - write(msg(1:240),'(2(a,i4,x),4(a,f8.3,x),6(a,es11.4))') & + write(msg(1:240),'(2(a,i4,1x),4(a,f8.3,1x),6(a,es11.4))') & 'Extreme surface sfc_state detected: i=',ig,'j=',jg, & 'lon=',G%geoLonT(i,j), 'lat=',G%geoLatT(i,j), & 'x=',G%gridLonT(i), 'y=',G%gridLatT(j), & @@ -3579,7 +3567,7 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo call sum_across_PEs(numberOfErrors) if (numberOfErrors>0) then - write(msg(1:240),'(3(a,i9,x))') 'There were a total of ',numberOfErrors, & + write(msg(1:240),'(3(a,i9,1x))') 'There were a total of ',numberOfErrors, & 'locations detected with extreme surface values!' call MOM_error(FATAL, trim(msg)) endif @@ -3589,7 +3577,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then - call rotate_surface_state(sfc_state, G, sfc_state_in, G_in, -turns) + call rotate_surface_state(sfc_state, sfc_state_in, G_in, -turns) call deallocate_surface_state(sfc_state) endif diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 19f14ceac3..c1dfd500dc 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -178,11 +178,7 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) dvdx, dudy, & ! Contributions to the circulation around q-points [L2 T-1 ~> m2 s-1] rel_vort, & ! Relative vorticity at q-points [T-1 ~> s-1]. abs_vort, & ! Absolute vorticity at q-points [T-1 ~> s-1]. - q2, & ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. - max_fvq, & ! The maximum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. - min_fvq, & ! The minimum of the adjacent values of (-u) times absolute vorticity [L T-2 ~> m s-2]. - max_fuq, & ! The maximum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. - min_fuq ! The minimum of the adjacent values of u times absolute vorticity [L T-2 ~> m s-2]. + q2 ! Relative vorticity over thickness [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. @@ -193,9 +189,6 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv) real, parameter :: C1_12=1.0/12.0 ! C1_12 = 1/12 real, parameter :: C1_24=1.0/24.0 ! C1_24 = 1/24 - real :: absolute_vorticity ! Absolute vorticity [T-1 ~> s-1]. - real :: relative_vorticity ! Relative vorticity [T-1 ~> s-1]. - real :: Ih ! Inverse of thickness [H-1 ~> m-1 or m2 kg-1]. real :: max_Ihq, min_Ihq ! The maximum and minimum of the nearby Ihq [H-1 ~> m-1 or m2 kg-1]. real :: hArea_q ! The sum of area times thickness of the cells ! surrounding a q point [H L2 ~> m3 or kg]. diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 18ea07b313..7d20409453 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -831,7 +831,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables - logical :: use_temperature, use_EOS + logical :: use_EOS ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 3cb1ebf399..7f91428c94 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -17,7 +17,7 @@ module MOM_barotropic use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : vardesc, var_desc, MOM_read_data, slasher -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, open_boundary_query +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, open_boundary_query use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, register_restart_pair @@ -1245,13 +1245,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & + CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else - CS%IDatu(I,j) = 1.0 / Htot_avg + CS%IDatu(I,j) = GV%Z_to_H / Htot_avg endif endif @@ -1271,13 +1271,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & + CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else - CS%IDatv(i,J) = 1.0 / Htot_avg + CS%IDatv(i,J) = GV%Z_to_H / Htot_avg endif endif @@ -2776,7 +2776,6 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) logical :: use_BT_cont type(memory_size_type) :: MS - character(len=200) :: mesg integer :: i, j, k, is, ie, js, je, nz if (.not.CS%module_is_initialized) call MOM_error(FATAL, & @@ -3053,7 +3052,7 @@ end subroutine apply_velocity_OBCs !! boundary conditions, as developed by Mehmet Ilicak. subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) - type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. + type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or @@ -3086,10 +3085,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. - integer :: i, j, k, is, ie, js, je, n, nz, Isq, Ieq, Jsq, Jeq + integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw - logical :: OBC_used type(OBC_segment_type), pointer :: segment !< Open boundary segment is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3306,7 +3304,6 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: wt_arith ! The weight for the arithmetic mean thickness [nondim]. ! The harmonic mean uses a weight of (1 - wt_arith). - real :: Rh ! A ratio of summed thicknesses [nondim] real :: e_u(SZIB_(G),SZK_(GV)+1) ! The interface heights at u-velocity points [H ~> m or kg m-2] real :: e_v(SZI_(G),SZK_(GV)+1) ! The interface heights at v-velocity points [H ~> m or kg m-2] real :: D_shallow_u(SZI_(G)) ! The height of the shallower of the adjacent bathymetric depths @@ -3622,8 +3619,6 @@ function uhbt_to_ubt(uhbt, BTC) result(ubt) real :: uherr_min, uherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -3757,8 +3752,6 @@ function vhbt_to_vbt(vhbt, BTC) result(vbt) real :: vherr_min, vherr_max ! The bounding values of the transport error [H L2 T-1 ~> m3 s-1 or kg s-1] ! or [H L2 ~> m3 or kg]. real, parameter :: tol = 1.0e-10 ! A fractional match tolerance [nondim] - real :: dvel ! Temporary variable used in the limiting the velocity [L T-1 ~> m s-1] or [L ~> m]. - real :: vsr ! Temporary variable used in the limiting the velocity [nondim]. real, parameter :: vs1 = 1.25 ! Nondimensional parameters used in limiting real, parameter :: vs2 = 2.0 ! the velocity, starting at vs1, with the ! maximum increase of vs2, both [nondim]. @@ -4295,8 +4288,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! name in wave_drag_file. real :: vel_rescale ! A rescaling factor for horizontal velocity from the representation in ! a restart file to the internal representation in this run. - real :: uH_rescale ! A rescaling factor for thickness transports from the representation in - ! a restart file to the internal representation in this run. real :: mean_SL ! The mean sea level that is used along with the bathymetry to estimate the ! geometry when LINEARIZED_BT_CORIOLIS is true or BT_NONLIN_STRESS is false [Z ~> m]. real :: det_de ! The partial derivative due to self-attraction and loading of the reference @@ -4309,7 +4300,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: apply_bt_drag, use_BT_cont_type + logical :: use_BT_cont_type character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4748,8 +4739,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, dtbt_tmp = -1.0 if (query_initialized(CS%dtbt, "DTBT", restart_CS)) then dtbt_tmp = CS%dtbt - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - dtbt_tmp = (US%s_to_T / US%s_to_T_restart) * CS%dtbt + if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & + dtbt_tmp = (1.0 / US%s_to_T_restart) * CS%dtbt endif ! Estimate the maximum stable barotropic time step. @@ -4909,8 +4900,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%vbtav(i,J) = CS%vbtav(i,J) + CS%frhatv(i,J,k) * v(i,J,k) enddo ; enddo ; enddo elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do j=js,je ; do I=is-1,ie ; CS%ubtav(I,j) = vel_rescale * CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbtav(i,J) = vel_rescale * CS%vbtav(i,J) ; enddo ; enddo endif @@ -4921,8 +4912,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = CS%ubtav(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = CS%vbtav(i,J) ; enddo ; enddo elseif ((US%s_to_T_restart*US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L*US%s_to_T_restart) /= (US%m_to_L_restart*US%s_to_T)) then - vel_rescale = (US%m_to_L*US%s_to_T_restart) / (US%m_to_L_restart*US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do j=js,je ; do I=is-1,ie ; CS%ubt_IC(I,j) = vel_rescale * CS%ubt_IC(I,j) ; enddo ; enddo do J=js-1,je ; do i=is,ie ; CS%vbt_IC(i,J) = vel_rescale * CS%vbt_IC(i,J) ; enddo ; enddo endif @@ -5022,11 +5013,12 @@ end subroutine barotropic_end !> This subroutine is used to register any fields from MOM_barotropic.F90 !! that should be written to or read from the restart file. -subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) +subroutine register_barotropic_restarts(HI, GV, US, param_file, CS, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(barotropic_CS), intent(inout) :: CS !< Barotropic control structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables @@ -5056,7 +5048,8 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) hor_grid='u', z_grid='1') vd(3) = var_desc("vbtav","m s-1","Time mean barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubtav, CS%vbtav, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) if (CS%gradual_BT_ICs) then vd(2) = var_desc("ubt_IC", "m s-1", & @@ -5065,12 +5058,12 @@ subroutine register_barotropic_restarts(HI, GV, param_file, CS, restart_CS) vd(3) = var_desc("vbt_IC", "m s-1", & longname="Next initial condition for the barotropic meridional velocity",& hor_grid='v', z_grid='1') - call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS) + call register_restart_pair(CS%ubt_IC, CS%vbt_IC, vd(2), vd(3), .false., restart_CS, & + conversion=US%L_T_to_m_s) endif - call register_restart_field(CS%dtbt, "DTBT", .false., restart_CS, & - longname="Barotropic timestep", units="seconds") + longname="Barotropic timestep", units="seconds", conversion=US%T_to_s) end subroutine register_barotropic_restarts diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 new file mode 100644 index 0000000000..55bd471fee --- /dev/null +++ b/src/core/MOM_check_scaling.F90 @@ -0,0 +1,221 @@ +!> This module is used to check the dimensional scaling factors used by the MOM6 ocean model +module MOM_check_scaling + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity +use MOM_unique_scales, only : check_scaling_uniqueness, scales_to_powers +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_MOM6_scaling_factors + +contains + +!> Evaluate whether the dimensional scaling factors provide unique tests for all of the combinations +!! of dimensions that are used in MOM6 (or perhaps widely used), and if they are not unique, explore +!! whether another combination of scaling factors can be found that is unique or has less common +!! cases with coinciding scaling. +subroutine check_MOM6_scaling_factors(GV, US) + type(verticalGrid_type), pointer :: GV !< The container for vertical grid data + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + + ! Local variables + integer, parameter :: ndims = 6 ! The number of rescalable dimensional factors. + real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units. + integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. + character(len=2), dimension(ndims) :: key + ! character(len=128) :: mesg, msg_frag + integer, allocatable :: weights(:) + character(len=80), allocatable :: descriptions(:) + ! logical :: verbose, very_verbose + integer :: n, ns, max_pow + + ! Set the names and scaling factors of the dimensions being rescaled. + key(:) = ["Z", "H", "L", "T", "R", "Q"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg /) + call scales_to_powers(scales, scale_pow2) + max_pow = 40 ! 60 + + ! The first call is just to find out how many elements are in the list of scaling combinations. + call compose_dimension_list(ns, descriptions, weights) + + allocate(descriptions(ns)) + do n=1,ns ; descriptions(n) = "" ; enddo + allocate(weights(ns), source=0) + ! This call records all the list of powers, the descriptions, and their weights. + call compose_dimension_list(ns, descriptions, weights) + + call check_scaling_uniqueness("MOM6", descriptions, weights, key, scale_pow2, max_pow) + + deallocate(weights) + deallocate(descriptions) + +end subroutine check_MOM6_scaling_factors + + +!> This routine composes a list of the commonly used dimensional scaling factors in the MOM6 +!! code, along with weights reflecting the frequency of their occurrence in the MOM6 code or +!! other considerations of how likely the variables are be used. +subroutine compose_dimension_list(ns, des, wts) + integer, intent(out) :: ns !< The running sum of valid descriptions + character(len=*), allocatable, intent(inout) :: des(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integer weights for each scaling factor, + !! perhaps the number of times it occurs in the MOM6 code. + + ns = 0 + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 1239) ! Layer thicknesses + call add_scaling(ns, des, wts, "[Z ~> m]", 660) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 506) ! Horizontal velocities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 356) ! Densities + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 247) ! Rates + call add_scaling(ns, des, wts, "[T ~> s]", 237) ! Time intervals + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 231) ! Dynamic pressure + ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 181) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 174) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 163) ! Volume or mass transports + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 136) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[L ~> m]", 107) ! Horizontal distances + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 104) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 89) ! Inverse cell thicknesses + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 88) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 85) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 78) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 69) ! Squared shears and buoyancy frequency + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 68) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 67) ! Horizontal areas + + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 61) ! Specific volumes + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 62) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 60) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 57) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 52) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 51) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 45) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 42) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 33) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 35) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 33) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 32) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[R L Z T-2 ~> Pa]", 27) ! Wind stresses + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 33) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z L2 T-2 ~> J m-2]", 25) ! Integrated energy + ! call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]") ! Depth integral of pressures (25) + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 25) ! Integrated energy + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 24) ! Layer-integrated density + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 20) ! pbce or gtot + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 19) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 18) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 17) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 15) ! Slopes + call add_scaling(ns, des, wts, "[Z L2 ~> m3]", 14) ! Diagnostic volumes + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 12) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 14) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 12) ! Squared vertical distances + call add_scaling(ns, des, wts, "[R Z L2 T-1 ~> kg s-1]", 12) ! Mass fluxes + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 12) ! Inverse areas + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]", 11) ! Gravitational acceleration over density + call add_scaling(ns, des, wts, "[Z T-2 ~> m s-2]", 10) ! Buoyancy differences or their derivatives + ! Could also add [Z T-2 degC-1 ~> m s-2 degC-1] or [Z T-2 ppt-1 ~> m s-2 ppt-1] + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 10) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[L3 ~> m3]", 10) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 9) ! Inverse of denominator in some weighted averages + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 9) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 9) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 9) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 8) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) + call add_scaling(ns, des, wts, "[Q degC-1 ~> J kg-1 degC-1]", 7) ! Heat capacity + + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 6) ! Potential energy height derivatives + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 7) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R L2 T-2 Z-1 ~> Pa m-1]", 7) ! Converts depth to pressure + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 7) ! Rigidity of ice + call add_scaling(ns, des, wts, "[H L2 T-3 ~> m3 s-3]", 9) ! Kinetic energy diagnostics + call add_scaling(ns, des, wts, "[H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]", 6) ! Layer potential vorticity + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 3) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[Z2 L-2 ~> 1]", 1) ! Slopes squared + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 6) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 6) ! Pressure conversion factor + ! Could also add [m T2 R-1 L-2 ~> m Pa-1] + ! Could also add [degC T2 R-1 L-2 ~> degC Pa-1] + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 5) ! Vertical density gradients + call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure + call add_scaling(ns, des, wts, "[L Z-1 ~> nondim]", 4) ! Inverse slopes + call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 20) ! Diagnostic conversions to mass + ! Could also add [m3 H-1 L-2 ~> 1 or m3 kg-1] + call add_scaling(ns, des, wts, "[Z T-2 R-1 ~> m4 s-2 kg-1]", 9) ! Gravitational acceleration over density + call add_scaling(ns, des, wts, "[R Z L4 T-3 ~> kg m2 s-3]", 9) ! MEKE fluxes + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 3) ! Thickness to pressure conversion + + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 3) ! Inverse of column mass + call add_scaling(ns, des, wts, "[L4 ~> m4]", 3) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[T-1 Z-1 ~> s-1 m-1]", 2) ! Barotropic PV, for some options + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 2) ! River mixing term [R Z2 T-1 ~> Pa s] + call add_scaling(ns, des, wts, "[degC Q-1 ~> kg degC J-1]", 2) ! Inverse heat capacity + ! Could add call add_scaling(ns, des, wts, "[Q-1 ~> kg J-1]", 1) ! Inverse heat content + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 2) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R Z-1 ~> kg m-4]", 3) ! Vertical density gradient + call add_scaling(ns, des, wts, "[R Z L2 ~> kg]", 3) ! Depth and time integrated mass fluxes + call add_scaling(ns, des, wts, "[R L2 T-3 ~> W m-2]", 3) ! Depth integrated friction work + call add_scaling(ns, des, wts, "[ppt2 R-2 ~> ppt2 m6 kg-2]", 3) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R L-1 ~> kg m-4]", 2) ! Horizontal density gradient + ! Could add call add_scaling(ns, des, wts, "[H Z ~> m2 or kg m-1]", 2) ! Temporary variables + call add_scaling(ns, des, wts, "[Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]", 2) ! Heating to PE change + call add_scaling(ns, des, wts, "[R2 L2 Z2 T-4 ~> Pa2]", 2) ! Squared wind stresses + call add_scaling(ns, des, wts, "[L-2 T-2 ~> m-2 s-2]", 2) ! Squared Laplacian of velocity + call add_scaling(ns, des, wts, "[T H Z-1 ~> s or s kg m-3]", 2) ! Time step times thickness conversion + call add_scaling(ns, des, wts, "[T H Z-1 R-1 ~> s m3 kg-1 or s]", 2) ! Time step over density with conversion + call add_scaling(ns, des, wts, "[H-3 ~> m-3 or m6 kg-3]", 1) ! A local term in ePBL + call add_scaling(ns, des, wts, "[H-4 ~> m-4 or m8 kg-4]", 1) ! A local term in ePBL + call add_scaling(ns, des, wts, "[H T Z-2 ~> s m-1 or kg s m-4]", 1) ! A local term in ePBL + + call add_scaling(ns, des, wts, "[H3 ~> m3 or kg3 m-6]", 1) ! Thickness cubed in a denominator + call add_scaling(ns, des, wts, "[H2 T-2 ~> m2 s-2 or kg2 m-4 s-2]", 1) ! Thickness times f squared + call add_scaling(ns, des, wts, "[H T2 R-1 Z-2 ~> m Pa-1 or s2 m-1]", 1) ! Pressure to thickness conversion + call add_scaling(ns, des, wts, "[L2 Z-2 ~> nondim]", 1) ! Inverse slope squared + call add_scaling(ns, des, wts, "[H R L2 T-2 ~> m Pa]", 1) ! Integral in thickness of pressure + call add_scaling(ns, des, wts, "[R T2 Z-1 ~> kg s2 m-4]", 1) ! Density divided by gravitational acceleration + +end subroutine compose_dimension_list + +!> Augment the count the valid unit descriptions, and add the provided description and its weight +!! to the end of the list if that list is allocated. +subroutine add_scaling(ns, descs, wts, scaling, weight) + integer, intent(inout) :: ns !< The running sum of valid descriptions. + character(len=*), allocatable, intent(inout) :: descs(:) !< The unit descriptions that have been converted + integer, allocatable, intent(inout) :: wts(:) !< A list of the integers for each scaling + character(len=*), intent(in) :: scaling !< The unit description that will be converted + integer, optional, intent(in) :: weight !< An optional weight or occurrence count + !! for this unit description, 1 by default. + + integer :: iend + + iend = index(scaling, "~>") + if (iend <= 1) then + call MOM_mesg("No scaling indicator ~> found for "//trim(scaling)) + else + ! Count and perhaps store this description and its weight. + ns = ns + 1 + if (allocated(descs)) descs(ns) = scaling + if (allocated(wts)) then + wts(ns) = 1 ; if (present(weight)) wts(ns) = weight + endif + endif + +end subroutine add_scaling + +end module MOM_check_scaling diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 917a4afdc3..d9855a98d3 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -253,8 +253,8 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) - tmp_T, & ! The column-integrated temperature [degC m3] - tmp_S ! The column-integrated salinity [ppt m3] + tmp_T, & ! The column-integrated temperature [degC m3] (unscaled to permit reproducing sum) + tmp_S ! The column-integrated salinity [ppt m3] (unscaled to permit reproducing sum) real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] @@ -294,6 +294,8 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe T%average = T%average + dV*Temp(i,j,k) S%minimum = min( S%minimum, Salt(i,j,k) ) ; S%maximum = max( S%maximum, Salt(i,j,k) ) S%average = S%average + dV*Salt(i,j,k) + tmp_T(i,j) = tmp_T(i,j) + dV*Temp(i,j,k) + tmp_S(i,j) = tmp_S(i,j) + dV*Salt(i,j,k) endif if (h_minimum > h(i,j,k)) h_minimum = h(i,j,k) endif diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index e5bd2f9ae9..402a6921ae 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -269,7 +269,6 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple - type(OBC_segment_type), pointer :: segment => NULL() use_visc_rem = present(visc_rem_u) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. @@ -1097,7 +1096,6 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC - type(OBC_segment_type), pointer :: segment => NULL() use_visc_rem = present(visc_rem_v) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 8f26918253..4b7ba9454a 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -143,7 +143,6 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: p5(5) ! Pressures at five quadrature points, never rescaled from Pa [Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] or [kg m-3] real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] or [kg m-3] - real :: w_left, w_right ! Left and right weights [nondim] real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. real :: GxRho ! The gravitational acceleration times density and unit conversion factors [Pa Z-1 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] or [m3 kg-1] @@ -1726,7 +1725,7 @@ end subroutine find_depth_of_pressure_in_cell !> Returns change in anomalous pressure change from top to non-dimensional -!! position pos between z_t and z_b +!! position pos between z_t and z_b [R L2 T-2 ~> Pa] real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EOS) real, intent(in) :: T_t !< Potential temperature at the cell top [degC] real, intent(in) :: T_b !< Potential temperature at the cell bottom [degC] @@ -1739,8 +1738,7 @@ real function frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, pos, EO real, intent(in) :: G_e !< The Earth's gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real, intent(in) :: pos !< The fractional vertical position, 0 to 1 [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure - real :: fract_dp_at_pos !< The change in pressure from the layer top to - !! fractional position pos [R L2 T-2 ~> Pa] + ! Local variables real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: dz ! Distance from the layer top [Z ~> m] diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f22fb9a862..e78209b5ff 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -177,6 +177,7 @@ module MOM_dynamics_split_RK2 integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 ! Split scheme only. integer :: id_uav = -1, id_vav = -1 @@ -315,6 +316,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: eta_pred + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! eta_pred is the predictor value of the free surface height or column mass, ! [H ~> m or kg m-2]. @@ -347,6 +349,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. 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 logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the @@ -357,10 +360,13 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: cont_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 u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + Idt_bc = 1./dt + sym=.false.;if (G%Domain%symmetric) sym=.true. ! switch to include symmetric domain in checksums showCallTree = callTree_showQuery() @@ -760,6 +766,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + endif do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo call cpu_clock_end(id_clock_btstep) @@ -958,6 +967,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_v_BT_accel_visc_rem > 0) & call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + if (CS%debug) then call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) call uvchksum("Corrector avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -972,9 +984,10 @@ end subroutine step_MOM_dyn_split_RK2 !> This subroutine sets up any auxiliary restart variables that are specific !! to the split-explicit time stepping scheme. All variables registered here should !! have the ability to be recreated if they are not present in a restart file. -subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, uh, vh) +subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_CS, uh, vh) type(hor_index_type), intent(in) :: HI !< Horizontal index 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 type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure @@ -984,7 +997,6 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] type(vardesc) :: vd(2) - character(len=40) :: mdl = "MOM_dynamics_split_RK2" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB @@ -1016,29 +1028,32 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, param_file, CS, restart_CS, u flux_units = get_flux_units(GV) if (GV%Boussinesq) then - vd(1) = var_desc("sfc",thickness_units,"Free surface Height",'h','1') + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) else - vd(1) = var_desc("p_bot",thickness_units,"Bottom Pressure",'h','1') + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) endif - call register_restart_field(CS%eta, vd(1), .false., restart_CS) - vd(1) = var_desc("u2","m s-1","Auxiliary Zonal velocity",'u','L') - vd(2) = var_desc("v2","m s-1","Auxiliary Meridional velocity",'v','L') - call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') + vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) - vd(1) = var_desc("h2",thickness_units,"Auxiliary Layer Thickness",'h','L') - call register_restart_field(CS%h_av, vd(1), .false., restart_CS) + call register_restart_field(CS%h_av, "h2", .false., restart_CS, & + longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) - vd(1) = var_desc("uh",flux_units,"Zonal thickness flux",'u','L') - vd(2) = var_desc("vh",flux_units,"Meridional thickness flux",'v','L') - call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') + vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & + conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) - vd(1) = var_desc("diffu","m s-2","Zonal horizontal viscous acceleration",'u','L') - vd(2) = var_desc("diffv","m s-2","Meridional horizontal viscous acceleration",'v','L') - call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS) + vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') + vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) - call register_barotropic_restarts(HI, GV, param_file, CS%barotropic_CSp, & - restart_CS) + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) end subroutine register_restarts_dyn_split_RK2 @@ -1238,8 +1253,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do j=js,je ; do i=is,ie CS%eta(i,j) = CS%eta(i,j) + h(i,j,k) enddo ; enddo ; enddo - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=js,je ; do i=is,ie ; CS%eta(i,j) = H_rescale * CS%eta(i,j) ; enddo ; enddo endif ! Copy eta into an output array. @@ -1251,14 +1266,12 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%diffu,"diffu",restart_CS) .or. & .not. query_initialized(CS%diffv,"diffv",restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, & - TD=thickness_diffuse_CSp) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) else if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - (US%m_to_L * US%s_to_T_restart**2 /= US%m_to_L_restart * US%s_to_T**2) ) then - accel_rescale = (US%m_to_L * US%s_to_T_restart**2) / (US%m_to_L_restart * US%s_to_T**2) + (US%s_to_T_restart**2 /= US%m_to_L_restart) ) then + accel_rescale = US%s_to_T_restart**2 / US%m_to_L_restart do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB CS%diffu(I,j,k) = accel_rescale * CS%diffu(I,j,k) enddo ; enddo ; enddo @@ -1273,8 +1286,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = v(i,J,k) ; enddo ; enddo ; enddo elseif ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = vel_rescale * CS%u_av(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; CS%v_av(i,J,k) = vel_rescale * CS%v_av(i,J,k) ; enddo ; enddo ; enddo endif @@ -1291,15 +1304,13 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param else if (.not. query_initialized(CS%h_av,"h2",restart_CS)) then CS%h_av(:,:,:) = h(:,:,:) - elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + elseif ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do k=1,nz ; do j=js,je ; do i=is,ie ; CS%h_av(i,j,k) = H_rescale * CS%h_av(i,j,k) ; enddo ; enddo ; enddo endif if ( (GV%m_to_H_restart * US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) /= & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T)) ) then - uH_rescale = (GV%m_to_H * US%m_to_L**2 * US%s_to_T_restart) / & - (GV%m_to_H_restart * US%m_to_L_restart**2 * US%s_to_T) + (US%s_to_T_restart /= (GV%m_to_H_restart * US%m_to_L_restart**2)) ) then + uH_rescale = US%s_to_T_restart / (GV%m_to_H_restart * US%m_to_L_restart**2) do k=1,nz ; do j=js,je ; do I=G%IscB,G%IecB ; uh(I,j,k) = uH_rescale * uh(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=G%JscB,G%JecB ; do i=is,ie ; vh(i,J,k) = uH_rescale * vh(i,J,k) ; enddo ; enddo ; enddo endif @@ -1313,6 +1324,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call cpu_clock_end(id_clock_pass_init) flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & y_cell_method='sum', v_extensive=.true.) @@ -1330,10 +1342,18 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 9a58dddd0f..a7517ccc4f 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -154,7 +154,7 @@ module MOM_dynamics_unsplit !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -536,7 +536,6 @@ subroutine register_restarts_dyn_unsplit(HI, GV, param_file, CS) type(MOM_dyn_unsplit_CS), pointer :: CS !< The control structure set up by !! initialize_dyn_unsplit. - character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. character(len=48) :: thickness_units, flux_units integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -619,7 +618,7 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" logical :: use_tides @@ -694,10 +693,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index ec4a1aa843..9acb2b5c83 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -156,7 +156,7 @@ module MOM_dynamics_unsplit_RK2 !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the tidal forcing control structure - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() + type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. type(ALE_CS), pointer :: ALE_CSp => NULL() @@ -566,7 +566,7 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag ! Local variables character(len=40) :: mdl = "MOM_dynamics_unsplit_RK2" ! This module's name. - character(len=48) :: thickness_units, flux_units + character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" logical :: use_tides @@ -656,10 +656,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - y_cell_method='sum', v_extensive = .true.) + y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & - x_cell_method='sum', v_extensive = .true.) + x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 3248c09fa4..227623f5eb 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -170,6 +170,8 @@ module MOM_forcing_type !! exactly 0 away from shelves or on land. real, pointer, dimension(:,:) :: iceshelf_melt => NULL() !< Ice shelf melt rate (positive) !! or freezing (negative) [R Z T-1 ~> kg m-2 s-1] + real, pointer, dimension(:,:) :: shelf_sfc_mass_flux => NULL() !< Ice shelf surface mass flux + !! deposition from the atmosphere. [R Z T-1 ~> kg m-2 s-1] ! Scalars set by surface forcing modules real :: vPrecGlobalAdj = 0. !< adjustment to restoring vprec to zero out global net [kg m-2 s-1] @@ -263,15 +265,15 @@ module MOM_forcing_type !! ice needs to be accumulated, and the rigidity explicitly !! reset to zero at the driver level when appropriate. real, pointer, dimension(:,:) :: & - ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] - vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] + ustk0 => NULL(), & !< Surface Stokes drift, zonal [m s-1] + vstk0 => NULL() !< Surface Stokes drift, meridional [m s-1] real, pointer, dimension(:) :: & - stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] + stk_wavenumbers => NULL() !< The central wave number of Stokes bands [rad m-1] real, pointer, dimension(:,:,:) :: & - ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] + ustkb => NULL(), & !< Stokes Drift spectrum, zonal [m s-1] !! Horizontal - u points !! 3rd dimension - wavenumber - vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] + vstkb => NULL() !< Stokes Drift spectrum, meridional [m s-1] !! Horizontal - v points !! 3rd dimension - wavenumber @@ -377,7 +379,6 @@ module MOM_forcing_type ! Iceberg + Ice shelf diagnostic handles integer :: id_ustar_ice_cover = -1 integer :: id_frac_ice_cover = -1 - ! wave forcing diagnostics handles. integer :: id_lamult = -1 !>@} @@ -703,7 +704,7 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & fluxes%num_msg = fluxes%num_msg + 1 write(mesg,'("Penetrating shortwave of ",1pe17.10, & &" exceeds total shortwave of ",1pe17.10,& - &" at ",1pg11.4,"E, "1pg11.4,"N.")') & + &" at ",1pg11.4,",E,",1pg11.4,"N.")') & Pen_SW_tot(i), I_Cp_Hconvert*scale*dt * fluxes%sw(i,j), & G%geoLonT(i,j), G%geoLatT(i,j) call MOM_error(WARNING,mesg) @@ -1488,39 +1489,41 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, !========================================================================= ! area averaged surface mass transport - handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & - long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)',& - units='kg m-2 s-1', standard_name='water_flux_into_sea_water_area_averaged', & - cmor_field_name='ave_wfo', & - cmor_standard_name='rainfall_flux_area_averaged', & + handles%id_prcme_ga = register_scalar_field('ocean_model', 'PRCmE_ga', Time, diag, & + long_name='Area averaged net surface water flux (precip+melt+liq runoff+ice calving-evap)', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_flux_into_sea_water_area_averaged', & + cmor_field_name='ave_wfo', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Water Transport Into Sea Water Area Averaged') - handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag,& - long_name='Area averaged evap/condense at ocean surface', & - units='kg m-2 s-1', standard_name='water_evaporation_flux_area_averaged', & - cmor_field_name='ave_evs', & - cmor_standard_name='water_evaporation_flux_area_averaged', & + handles%id_evap_ga = register_scalar_field('ocean_model', 'evap_ga', Time, diag, & + long_name='Area averaged evap/condense at ocean surface', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='water_evaporation_flux_area_averaged', & + cmor_field_name='ave_evs', cmor_standard_name='water_evaporation_flux_area_averaged', & cmor_long_name='Evaporation Where Ice Free Ocean over Sea Area Averaged') - handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& - long_name='Area integrated liquid precip into ocean', units='kg m-2 s-1', & - standard_name='rainfall_flux_area_averaged', & - cmor_field_name='ave_pr', & - cmor_standard_name='rainfall_flux_area_averaged', & + handles%id_lprec_ga = register_scalar_field('ocean_model', 'lprec_ga', Time, diag,& + long_name='Area integrated liquid precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + standard_name='rainfall_flux_area_averaged', & + cmor_field_name='ave_pr', cmor_standard_name='rainfall_flux_area_averaged', & cmor_long_name='Rainfall Flux where Ice Free Ocean over Sea Area Averaged') - handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag,& - long_name='Area integrated frozen precip into ocean', units='kg m-2 s-1', & + handles%id_fprec_ga = register_scalar_field('ocean_model', 'fprec_ga', Time, diag, & + long_name='Area integrated frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & standard_name='snowfall_flux_area_averaged', & - cmor_field_name='ave_prsn', & - cmor_standard_name='snowfall_flux_area_averaged', & + cmor_field_name='ave_prsn',cmor_standard_name='snowfall_flux_area_averaged', & cmor_long_name='Snowfall Flux where Ice Free Ocean over Sea Area Averaged') handles%id_precip_ga = register_scalar_field('ocean_model', 'precip_ga', Time, diag, & - long_name='Area averaged liquid+frozen precip into ocean', units='kg m-2 s-1') + long_name='Area averaged liquid+frozen precip into ocean', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) handles%id_vprec_ga = register_scalar_field('ocean_model', 'vrec_ga', Time, diag, & - long_name='Area averaged virtual liquid precip due to SSS restoring', units='kg m-2 s-1') + long_name='Area averaged virtual liquid precip due to SSS restoring', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) !=============================================================== ! surface heat flux maps @@ -1819,12 +1822,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_net_heat_coupler_ga = register_scalar_field('ocean_model', & 'net_heat_coupler_ga', Time, diag, & long_name='Area averaged surface heat flux from SW+LW+latent+sensible+seaice_melt_heat (via the coupler)',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_net_heat_surface_ga = register_scalar_field('ocean_model', & 'net_heat_surface_ga', Time, diag, long_name= & 'Area averaged surface heat flux from SW+LW+lat+sens+mass+frazil+restore+seaice_melt_heat or flux adjustments', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfds', & cmor_standard_name='surface_downward_heat_flux_in_sea_water_area_averaged', & cmor_long_name= & @@ -1833,7 +1836,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sw_ga = register_scalar_field('ocean_model', & 'sw_ga', Time, diag, & long_name='Area averaged net downward shortwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rsntds', & cmor_standard_name='net_downward_shortwave_flux_at_sea_water_surface_area_averaged',& cmor_long_name= & @@ -1842,12 +1845,12 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_LwLatSens_ga = register_scalar_field('ocean_model',& 'LwLatSens_ga', Time, diag, & long_name='Area averaged longwave+latent+sensible heating',& - units='W m-2') + units='W m-2', conversion=US%QRZ_T_to_W_m2) handles%id_lw_ga = register_scalar_field('ocean_model', & 'lw_ga', Time, diag, & long_name='Area averaged net downward longwave at sea water surface', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_rlntds', & cmor_standard_name='surface_net_downward_longwave_flux_area_averaged',& cmor_long_name= & @@ -1856,7 +1859,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_lat_ga = register_scalar_field('ocean_model', & 'lat_ga', Time, diag, & long_name='Area averaged surface downward latent heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hflso', & cmor_standard_name='surface_downward_latent_heat_flux_area_averaged',& cmor_long_name= & @@ -1865,7 +1868,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, handles%id_sens_ga = register_scalar_field('ocean_model', & 'sens_ga', Time, diag, & long_name='Area averaged downward sensible heat flux', & - units='W m-2', & + units='W m-2', conversion=US%QRZ_T_to_W_m2, & cmor_field_name='ave_hfsso', & cmor_standard_name='surface_downward_sensible_heat_flux_area_averaged',& cmor_long_name= & @@ -1982,8 +1985,8 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) ! applied based on the time interval stored in flux_tmp. real :: wt1 ! The relative weight of the previous fluxes [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, i0, j0 - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, isr, ier, jsr, jer + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2099,6 +2102,12 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) fluxes%iceshelf_melt(i,j) = flux_tmp%iceshelf_melt(i,j) enddo ; enddo endif + if (associated(fluxes%shelf_sfc_mass_flux) & + .and. associated(flux_tmp%shelf_sfc_mass_flux)) then + do i=isd,ied ; do j=jsd,jed + fluxes%shelf_sfc_mass_flux(i,j) = flux_tmp%shelf_sfc_mass_flux(i,j) + enddo ; enddo + endif if (associated(fluxes%frac_shelf_h) .and. associated(flux_tmp%frac_shelf_h)) then do i=isd,ied ; do j=jsd,jed fluxes%frac_shelf_h(i,j) = flux_tmp%frac_shelf_h(i,j) @@ -2175,12 +2184,12 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) associated(fluxes%ustar_gustless)) then do j=js,je ; do i=is,ie taux2 = 0.0 - if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0) & + if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & taux2 = (G%mask2dCu(I-1,j) * forces%taux(I-1,j)**2 + & G%mask2dCu(I,j) * forces%taux(I,j)**2) / & (G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) tauy2 = 0.0 - if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0) & + if ((G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) > 0.0) & tauy2 = (G%mask2dCv(i,J-1) * forces%tauy(i,J-1)**2 + & G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) @@ -2275,7 +2284,7 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) type(diag_ctrl), intent(inout) :: diag !< diagnostic type type(forcing_diags), intent(inout) :: handles !< diagnostic id for diag_manager - integer :: i,j,is,ie,js,je + integer :: is, ie, js, je type(mech_forcing), pointer :: forces integer :: turns @@ -2340,7 +2349,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h real, dimension(SZI_(diag%G),SZJ_(diag%G)) :: res ! A temporary array for combinations ! of fluxes [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] real :: total_transport ! for diagnosing integrated boundary transport, in MKS units of [kg s-1] or [W] - real :: ave_flux ! for diagnosing averaged boundary flux, in MKS units of [kg m-2 s-1] or [W m-2] + real :: ave_flux ! for diagnosing averaged boundary flux in [R Z T-1 ~> kg m-2 s-1] or [Q R Z T-1 ~> W m-2] real :: I_dt ! inverse time step [T-1 ~> s-1] real :: ppt2mks ! conversion between ppt and mks units [nondim] integer :: turns ! Number of index quarter turns @@ -2388,7 +2397,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_prcme, total_transport, diag) endif if (handles%id_prcme_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif @@ -2458,7 +2467,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_evap, total_transport, diag) endif if ((handles%id_evap_ga > 0) .and. associated(fluxes%evap)) then - ave_flux = global_area_mean(fluxes%evap, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_evap_ga, ave_flux, diag) endif @@ -2472,7 +2481,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_precip, total_transport, diag) endif if (handles%id_precip_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(res, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_precip_ga, ave_flux, diag) endif endif @@ -2484,7 +2493,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lprec, total_transport, diag) endif if (handles%id_lprec_ga > 0) then - ave_flux = global_area_mean(fluxes%lprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_lprec_ga, ave_flux, diag) endif endif @@ -2496,7 +2505,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_fprec, total_transport, diag) endif if (handles%id_fprec_ga > 0) then - ave_flux = global_area_mean(fluxes%fprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_fprec_ga, ave_flux, diag) endif endif @@ -2508,7 +2517,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_vprec, total_transport, diag) endif if (handles%id_vprec_ga > 0) then - ave_flux = global_area_mean(fluxes%vprec, G, scale=US%RZ_T_to_kg_m2s) + ave_flux = global_area_mean(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) call post_data(handles%id_vprec_ga, ave_flux, diag) endif endif @@ -2618,7 +2627,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif if (handles%id_net_heat_coupler_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif endif @@ -2662,7 +2671,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif if (handles%id_net_heat_surface_ga > 0) then - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif endif @@ -2733,7 +2742,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h do j=js,je ; do i=is,ie res(i,j) = ((fluxes%lw(i,j) + fluxes%latent(i,j)) + fluxes%sens(i,j)) enddo ; enddo - ave_flux = global_area_mean(res, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(res, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_LwLatSens_ga, ave_flux, diag) endif @@ -2753,7 +2762,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_sw, total_transport, diag) endif if ((handles%id_sw_ga > 0) .and. associated(fluxes%sw)) then - ave_flux = global_area_mean(fluxes%sw, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sw_ga, ave_flux, diag) endif @@ -2765,7 +2774,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lw, total_transport, diag) endif if ((handles%id_lw_ga > 0) .and. associated(fluxes%lw)) then - ave_flux = global_area_mean(fluxes%lw, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lw_ga, ave_flux, diag) endif @@ -2777,7 +2786,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_lat, total_transport, diag) endif if ((handles%id_lat_ga > 0) .and. associated(fluxes%latent)) then - ave_flux = global_area_mean(fluxes%latent, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_lat_ga, ave_flux, diag) endif @@ -2823,7 +2832,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_sens, total_transport, diag) endif if ((handles%id_sens_ga > 0) .and. associated(fluxes%sens)) then - ave_flux = global_area_mean(fluxes%sens, G, scale=US%QRZ_T_to_W_m2) + ave_flux = global_area_mean(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) call post_data(handles%id_sens_ga, ave_flux, diag) endif @@ -2928,7 +2937,8 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & - shelf, iceberg, salt, fix_accum_bug, cfc, waves) + shelf, iceberg, salt, fix_accum_bug, cfc, waves, & + shelf_sfc_accumulation) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -2942,14 +2952,20 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & !! accumulation of ustar_gustless logical, optional, intent(in) :: cfc !< If present and true, allocate cfc 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 + !! over ice shelves and ice sheets. ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water + logical :: shelf_sfc_acc isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + shelf_sfc_acc=.false. + if (present(shelf_sfc_accumulation)) shelf_sfc_acc=shelf_sfc_accumulation + call myAlloc(fluxes%ustar,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) @@ -2987,9 +3003,13 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%p_surf,isd,ied,jsd,jed, press) - call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) - call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + ! These fields should only be allocated if ice shelf is enabled. + if (present(shelf)) then; if (shelf) then + call myAlloc(fluxes%frac_shelf_h,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%ustar_shelf,isd,ied,jsd,jed, shelf) + call myAlloc(fluxes%iceshelf_melt,isd,ied,jsd,jed, shelf) + if (shelf_sfc_acc) call myAlloc(fluxes%shelf_sfc_mass_flux,isd,ied,jsd,jed, shelf_sfc_acc) + endif; endif !These fields should only on allocated when iceberg area is being passed through the coupler. call myAlloc(fluxes%ustar_berg,isd,ied,jsd,jed, iceberg) @@ -3075,7 +3095,6 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - logical :: heat_water isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -3104,7 +3123,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & if (present(waves)) then; if (waves) then; if (.not. present(num_stk_bands)) then call MOM_error(FATAL,"Requested to & - initialize with waves, but no waves are present.") + &initialize with waves, but no waves are present.") endif if (num_stk_bands > 0) then if (.not.associated(forces%ustkb)) then @@ -3209,7 +3228,7 @@ subroutine myAlloc(array, is, ie, js, je, flag) logical, optional, intent(in) :: flag !< Flag to indicate to allocate if (present(flag)) then ; if (flag) then ; if (.not.associated(array)) then - allocate(array(is:ie,js:je)) ; array(is:ie,js:je) = 0.0 + allocate(array(is:ie,js:je), source=0.0) endif ; endif ; endif end subroutine myAlloc @@ -3257,6 +3276,8 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%ustar_tidal)) deallocate(fluxes%ustar_tidal) if (associated(fluxes%ustar_shelf)) deallocate(fluxes%ustar_shelf) if (associated(fluxes%iceshelf_melt)) deallocate(fluxes%iceshelf_melt) + if (associated(fluxes%shelf_sfc_mass_flux)) & + deallocate(fluxes%shelf_sfc_mass_flux) if (associated(fluxes%frac_shelf_h)) deallocate(fluxes%frac_shelf_h) if (associated(fluxes%ustar_berg)) deallocate(fluxes%ustar_berg) if (associated(fluxes%area_berg)) deallocate(fluxes%area_berg) @@ -3355,6 +3376,7 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) call rotate_array(fluxes_in%frac_shelf_h, turns, fluxes%frac_shelf_h) call rotate_array(fluxes_in%ustar_shelf, turns, fluxes%ustar_shelf) call rotate_array(fluxes_in%iceshelf_melt, turns, fluxes%iceshelf_melt) + call rotate_array(fluxes_in%shelf_sfc_mass_flux, turns, fluxes%shelf_sfc_mass_flux) endif if (do_iceberg) then @@ -3472,18 +3494,18 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: Rho0 !< A reference density of seawater [R ~> kg m-3], - !! as used to calculate ustar. + !! as used to calculate ustar. logical, optional, intent(in) :: UpdateUstar !< A logical to determine if Ustar should be directly averaged - !! or updated from mean tau. + !! or updated from mean tau. - real :: tx_mean, ty_mean, avg - real :: iRho0 + real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg, tau2ustar integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB - iRho0 = US%L_to_Z / Rho0 + Irho0 = US%L_to_Z / Rho0 tau2ustar = .false. if (present(UpdateUstar)) tau2ustar = UpdateUstar @@ -3492,155 +3514,155 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) do_press, do_iceberg) if (do_stress) then - tx_mean = global_area_mean_u(forces%taux, G) + tx_mean = global_area_mean_u(forces%taux, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=js,je ; do i=isB,ieB - if (G%mask2dCu(I,j) > 0.) forces%taux(I,j) = tx_mean + if (G%mask2dCu(I,j) > 0.0) forces%taux(I,j) = tx_mean enddo ; enddo - ty_mean = global_area_mean_v(forces%tauy, G) + ty_mean = global_area_mean_v(forces%tauy, G, tmp_scale=US%Z_to_L*US%RL2_T2_to_Pa) do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) forces%tauy(i,J) = ty_mean + if (G%mask2dCv(i,J) > 0.0) forces%tauy(i,J) = ty_mean enddo ; enddo if (tau2ustar) then do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*iRho0) + if (G%mask2dT(i,j) > 0.0) forces%ustar(i,j) = sqrt(sqrt(tx_mean**2 + ty_mean**2)*Irho0) enddo ; enddo else - call homogenize_field_t(forces%ustar, G) + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) endif else if (do_ustar) then - call homogenize_field_t(forces%ustar, G) + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) endif endif if (do_shelf) then - call homogenize_field_u(forces%rigidity_ice_u, G) - call homogenize_field_v(forces%rigidity_ice_v, G) + call homogenize_field_u(forces%rigidity_ice_u, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) + call homogenize_field_v(forces%rigidity_ice_v, G, tmp_scale=US%L_T_to_m_s*US%L_to_m**2*US%L_to_Z) call homogenize_field_u(forces%frac_shelf_u, G) call homogenize_field_v(forces%frac_shelf_v, G) endif if (do_press) then ! NOTE: p_surf_SSH either points to p_surf or p_surf_full - call homogenize_field_t(forces%p_surf, G) - call homogenize_field_t(forces%p_surf_full, G) - call homogenize_field_t(forces%net_mass_src, G) + call homogenize_field_t(forces%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) + call homogenize_field_t(forces%net_mass_src, G, tmp_scale=US%RZ_T_to_kg_m2s) endif if (do_iceberg) then call homogenize_field_t(forces%area_berg, G) - call homogenize_field_t(forces%mass_berg, G) + call homogenize_field_t(forces%mass_berg, G, tmp_scale=US%RZ_to_kg_m2) endif end subroutine homogenize_mech_forcing !< Homogenize the fluxes -subroutine homogenize_forcing(fluxes, G) - type(forcing), intent(inout) :: fluxes !< Input forcing struct - type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing +subroutine homogenize_forcing(fluxes, G, GV, US) + type(forcing), intent(inout) :: fluxes !< Input forcing struct + type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real :: avg logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy - integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) if (do_ustar) then - call homogenize_field_t(fluxes%ustar, G) - call homogenize_field_t(fluxes%ustar_gustless, G) + call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) endif if (do_water) then - call homogenize_field_t(fluxes%evap, G) - call homogenize_field_t(fluxes%lprec, G) - call homogenize_field_t(fluxes%lprec, G) - call homogenize_field_t(fluxes%fprec, G) - call homogenize_field_t(fluxes%vprec, G) - call homogenize_field_t(fluxes%lrunoff, G) - call homogenize_field_t(fluxes%frunoff, G) - call homogenize_field_t(fluxes%seaice_melt, G) - call homogenize_field_t(fluxes%netMassOut, G) - call homogenize_field_t(fluxes%netMassIn, G) + call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%fprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%vprec, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%lrunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%frunoff, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%seaice_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + ! These two calls might not be needed. + call homogenize_field_t(fluxes%netMassOut, G, tmp_scale=GV%H_to_mks) + call homogenize_field_t(fluxes%netMassIn, G, tmp_scale=GV%H_to_mks) !This was removed and I don't think replaced. Not needed? !call homogenize_field_t(fluxes%netSalt, G) endif if (do_heat) then - call homogenize_field_t(fluxes%seaice_melt_heat, G) - call homogenize_field_t(fluxes%sw, G) - call homogenize_field_t(fluxes%lw, G) - call homogenize_field_t(fluxes%latent, G) - call homogenize_field_t(fluxes%sens, G) - call homogenize_field_t(fluxes%latent_evap_diag, G) - call homogenize_field_t(fluxes%latent_fprec_diag, G) - call homogenize_field_t(fluxes%latent_frunoff_diag, G) + call homogenize_field_t(fluxes%seaice_melt_heat, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%lw, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%sens, G, tmp_scale=US%QRZ_T_to_W_m2) + !### These are for diagnostics only and may not be needed. + call homogenize_field_t(fluxes%latent_evap_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_fprec_diag, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%latent_frunoff_diag, G, tmp_scale=US%QRZ_T_to_W_m2) endif - if (do_salt) call homogenize_field_t(fluxes%salt_flux, G) + if (do_salt) call homogenize_field_t(fluxes%salt_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) if (do_heat .and. do_water) then - call homogenize_field_t(fluxes%heat_content_cond, G) - call homogenize_field_t(fluxes%heat_content_icemelt, G) - call homogenize_field_t(fluxes%heat_content_lprec, G) - call homogenize_field_t(fluxes%heat_content_fprec, G) - call homogenize_field_t(fluxes%heat_content_vprec, G) - call homogenize_field_t(fluxes%heat_content_lrunoff, G) - call homogenize_field_t(fluxes%heat_content_frunoff, G) - call homogenize_field_t(fluxes%heat_content_massout, G) - call homogenize_field_t(fluxes%heat_content_massin, G) + call homogenize_field_t(fluxes%heat_content_cond, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_icemelt, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_fprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_vprec, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_lrunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_frunoff, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massout, G, tmp_scale=US%QRZ_T_to_W_m2) + call homogenize_field_t(fluxes%heat_content_massin, G, tmp_scale=US%QRZ_T_to_W_m2) endif - if (do_press) call homogenize_field_t(fluxes%p_surf, G) + if (do_press) call homogenize_field_t(fluxes%p_surf, G, tmp_scale=US%RL2_T2_to_Pa) if (do_shelf) then call homogenize_field_t(fluxes%frac_shelf_h, G) - call homogenize_field_t(fluxes%ustar_shelf, G) - call homogenize_field_t(fluxes%iceshelf_melt, G) + call homogenize_field_t(fluxes%ustar_shelf, G, tmp_scale=US%Z_to_m*US%s_to_T) + call homogenize_field_t(fluxes%iceshelf_melt, G, tmp_scale=US%RZ_T_to_kg_m2s) + call homogenize_field_t(fluxes%shelf_sfc_mass_flux, G, tmp_scale=US%RZ_T_to_kg_m2s) endif if (do_iceberg) then - call homogenize_field_t(fluxes%ustar_berg, G) + call homogenize_field_t(fluxes%ustar_berg, G, tmp_scale=US%Z_to_m*US%s_to_T) call homogenize_field_t(fluxes%area_berg, G) endif if (do_heat_added) then - call homogenize_field_t(fluxes%heat_added, G) + call homogenize_field_t(fluxes%heat_added, G, tmp_scale=US%QRZ_T_to_W_m2) endif ! The following fields are handled by drivers rather than control flags. if (associated(fluxes%sw_vis_dir)) & - call homogenize_field_t(fluxes%sw_vis_dir, G) + call homogenize_field_t(fluxes%sw_vis_dir, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_vis_dif)) & - call homogenize_field_t(fluxes%sw_vis_dif, G) + call homogenize_field_t(fluxes%sw_vis_dif, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dir)) & - call homogenize_field_t(fluxes%sw_nir_dir, G) + call homogenize_field_t(fluxes%sw_nir_dir, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%sw_nir_dif)) & - call homogenize_field_t(fluxes%sw_nir_dif, G) + call homogenize_field_t(fluxes%sw_nir_dif, G, tmp_scale=US%QRZ_T_to_W_m2) if (associated(fluxes%salt_flux_in)) & - call homogenize_field_t(fluxes%salt_flux_in, G) + call homogenize_field_t(fluxes%salt_flux_in, G, tmp_scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%salt_flux_added)) & - call homogenize_field_t(fluxes%salt_flux_added, G) + call homogenize_field_t(fluxes%salt_flux_added, G, tmp_scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%p_surf_full)) & - call homogenize_field_t(fluxes%p_surf_full, G) + call homogenize_field_t(fluxes%p_surf_full, G, tmp_scale=US%RL2_T2_to_Pa) if (associated(fluxes%buoy)) & - call homogenize_field_t(fluxes%buoy, G) + call homogenize_field_t(fluxes%buoy, G, tmp_scale=US%L_to_m**2*US%s_to_T**3) if (associated(fluxes%TKE_tidal)) & - call homogenize_field_t(fluxes%TKE_tidal, G) + call homogenize_field_t(fluxes%TKE_tidal, G, tmp_scale=US%RZ3_T3_to_W_m2) if (associated(fluxes%ustar_tidal)) & - call homogenize_field_t(fluxes%ustar_tidal, G) + call homogenize_field_t(fluxes%ustar_tidal, G, tmp_scale=US%Z_to_m*US%s_to_T) ! TODO: tracer flux homogenization ! Having a warning causes a lot of errors (each time step). @@ -3649,47 +3671,53 @@ subroutine homogenize_forcing(fluxes, G) end subroutine homogenize_forcing -subroutine homogenize_field_t(var, G) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(inout) :: var !< The variable to homogenize +subroutine homogenize_field_t(var, G, tmp_scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - avg = global_area_mean(var, G) + avg = global_area_mean(var, G, tmp_scale=tmp_scale) do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.) var(i,j) = avg + if (G%mask2dT(i,j) > 0.0) var(i,j) = avg enddo ; enddo end subroutine homogenize_field_t -subroutine homogenize_field_v(var, G) +subroutine homogenize_field_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, is, ie, jsB, jeB is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB - avg = global_area_mean_v(var, G) + avg = global_area_mean_v(var, G, tmp_scale=tmp_scale) do J=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,J) > 0.) var(i,J) = avg + if (G%mask2dCv(i,J) > 0.0) var(i,J) = avg enddo ; enddo end subroutine homogenize_field_v -subroutine homogenize_field_u(var, G) +subroutine homogenize_field_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value - real :: avg + real :: avg ! Global average of var, in the same units as var integer :: i, j, isB, ieB, js, je isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec - avg = global_area_mean_u(var, G) + avg = global_area_mean_u(var, G, tmp_scale=tmp_scale) do j=js,je ; do I=isB,ieB - if (G%mask2dCu(I,j) > 0.) var(I,j) = avg + if (G%mask2dCu(I,j) > 0.0) var(I,j) = avg enddo ; enddo end subroutine homogenize_field_u diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index d9ed8ffee4..f73fcc33af 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -207,7 +207,7 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v ! Local variables real :: mean_SeaLev_scale ! A scaling factor for the reference height variable [1] or [Z m-1 ~> 1] - integer :: isd, ied, jsd, jed, nk + integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: ied_max, jed_max integer :: niblock, njblock, nihalo, njhalo, nblocks, n, i, j diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 80d94ec7fe..38a3544703 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -98,7 +98,6 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & real :: slope ! The slope of density surfaces, calculated in a way ! that is always between -1 and 1. [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 Z-2 ~> kg2 m-8]. - real :: slope2_Ratio ! The ratio of the slope squared to slope_max squared. 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 :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. @@ -219,7 +218,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,slope,slope2_Ratio,l_seg) + !$OMP drdx,mag_grad2,slope,l_seg) do j=js,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -257,7 +256,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & hg2B = h(i,j,k)*h(i+1,j,k) + h_neglect2 hg2L = h(i,j,k-1)*h(i,j,k) + h_neglect2 hg2R = h(i+1,j,k-1)*h(i+1,j,k) + h_neglect2 - haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect @@ -329,7 +328,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdy,mag_grad2,slope,slope2_Ratio,l_seg) + !$OMP drdy,mag_grad2,slope,l_seg) do j=js-1,je ; do K=nz,2,-1 if (.not.(use_EOS)) then drdjA = 0.0 ; drdjB = 0.0 diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 41ba70f152..bd05a4da7a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -48,6 +48,9 @@ module MOM_open_boundary public open_boundary_test_extern_uv public open_boundary_test_extern_h public open_boundary_zero_normal_flow +public parse_segment_str +public parse_segment_manifest_str +public parse_segment_data_str public register_OBC, OBC_registry_init public register_file_OBC, file_OBC_end public segment_tracer_registry_init @@ -61,12 +64,10 @@ module MOM_open_boundary public rotate_OBC_config public rotate_OBC_init public initialize_segment_data +public flood_fill +public flood_fill2 integer, parameter, public :: OBC_NONE = 0 !< Indicates the use of no open boundary -integer, parameter, public :: OBC_SIMPLE = 1 !< Indicates the use of a simple inflow open boundary -integer, parameter, public :: OBC_WALL = 2 !< Indicates the use of a closed wall -integer, parameter, public :: OBC_FLATHER = 3 !< Indicates the use of a Flather open boundary -integer, parameter, public :: OBC_RADIATION = 4 !< Indicates the use of a radiation open boundary integer, parameter, public :: OBC_DIRECTION_N = 100 !< Indicates the boundary is an effective northern boundary integer, parameter, public :: OBC_DIRECTION_S = 200 !< Indicates the boundary is an effective southern boundary integer, parameter, public :: OBC_DIRECTION_E = 300 !< Indicates the boundary is an effective eastern boundary @@ -310,6 +311,9 @@ module MOM_open_boundary real :: ramp_value !< If ramp is True, where we are on the ramp from !! zero to one [nondim]. type(time_type) :: ramp_start_time !< Time when model was started. + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -357,11 +361,10 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - character(len=128) :: inputdir logical :: answers_2018, default_2018_answers logical :: check_reconstruction, check_remapping, force_bounds_in_subcell - character(len=32) :: remappingScheme -! This include declares and sets the variable "version". + character(len=64) :: remappingScheme + ! This include declares and sets the variable "version". # include "version_variable.h" allocate(OBC) @@ -608,7 +611,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & default=.false.) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & + call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", OBC%answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& "forms of the same expressions.", default=default_2018_answers) @@ -616,7 +619,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & check_reconstruction=check_reconstruction, check_remapping=check_remapping, & - force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=answers_2018) + force_bounds_in_subcell=force_bounds_in_subcell, answers_2018=OBC%answers_2018) endif ! OBC%number_of_segments > 0 @@ -651,7 +654,7 @@ subroutine initialize_segment_data(G, OBC, PF) character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names character(len=128) :: inputdir @@ -1630,7 +1633,7 @@ end subroutine parse_segment_data_str !> Parse all the OBC_SEGMENT_%%%_DATA strings again !! to see which need tracer reservoirs (all pes need to know). - subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) +subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle logical, intent(in) :: use_temperature !< If true, T and S are used @@ -1640,11 +1643,10 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix - character(len=32) :: varnam, fieldname + character(len=32) :: fieldname real :: value ! A value that is parsed from the segment data string [various units] character(len=32), dimension(MAX_OBC_FIELDS) :: fields ! segment field names type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - character(len=256) :: mesg ! Message for error messages. do n=1, OBC%number_of_segments segment => OBC%segment(n) @@ -1695,88 +1697,6 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) end subroutine parse_for_tracer_reservoirs -!> Parse an OBC_SEGMENT_%%%_PARAMS string -subroutine parse_segment_param_real(segment_str, var, param_value, debug ) - character(len=*), intent(in) :: segment_str !< A string in form of - !! "VAR1=file:foo1.nc(varnam1),VAR2=file:foo2.nc(varnam2),..." - character(len=*), intent(in) :: var !< The name of the variable for which parameters are needed - real, intent(out) :: param_value !< The value of the parameter - logical, optional, intent(in) :: debug !< If present and true, write verbose debugging messages - ! Local variables - character(len=128) :: word1, word2, word3, method - integer :: lword, nfields, n, m - logical :: continue,dbg - character(len=32), dimension(MAX_OBC_FIELDS) :: flds - - nfields = 0 - continue = .true. - dbg = .false. - if (PRESENT(debug)) dbg = debug - - do while (continue) - word1 = extract_word(segment_str,',',nfields+1) - if (trim(word1) == '') exit - nfields = nfields+1 - word2 = extract_word(word1,'=',1) - flds(nfields) = trim(word2) - enddo - - ! if (PRESENT(fields)) then - ! do n=1,nfields - ! fields(n) = flds(n) - ! enddo - ! endif - - ! if (PRESENT(num_fields)) then - ! num_fields = nfields - ! return - ! endif - - m=0 -! if (PRESENT(var)) then - do n=1,nfields - if (trim(var)==trim(flds(n))) then - m = n - exit - endif - enddo - if (m==0) then - call abort() - endif - - ! Process first word which will start with the fieldname - word3 = extract_word(segment_str,',',m) -! word1 = extract_word(word3,':',1) -! if (trim(word1) == '') exit - word2 = extract_word(word1,'=',1) - if (trim(word2) == trim(var)) then - method=trim(extract_word(word1,'=',2)) - lword=len_trim(method) - read(method(1:lword),*,err=987) param_value - ! if (method(lword-3:lword) == 'file') then - ! ! raise an error id filename/fieldname not in argument list - ! word1 = extract_word(word3,':',2) - ! filenam = extract_word(word1,'(',1) - ! fieldnam = extract_word(word1,'(',2) - ! lword=len_trim(fieldnam) - ! fieldnam = fieldnam(1:lword-1) ! remove trailing parenth - ! value=-999. - ! elseif (method(lword-4:lword) == 'value') then - ! filenam = 'none' - ! fieldnam = 'none' - ! word1 = extract_word(word3,':',2) - ! lword=len_trim(word1) - ! read(word1(1:lword),*,end=986,err=987) value - ! endif - endif -! endif - - return - 986 call MOM_error(FATAL,'End of record while parsing segment data specification! '//trim(segment_str)) - 987 call MOM_error(FATAL,'Error while parsing segment parameter specification! '//trim(segment_str)) - -end subroutine parse_segment_param_real - !> Initialize open boundary control structure and do any necessary rescaling of OBC !! fields that have been read from a restart file. subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) @@ -1821,8 +1741,8 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to ! permit timesteps to change between calls to the OBC code, the following would be needed: ! if ( OBC%radiation_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & -! ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then -! vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) +! (US%s_to_T_restart /= US%m_to_L_restart) ) then +! vel_rescale = US%s_to_T_restart / US%m_to_L_restart ! if (query_initialized(OBC%rx_normal, "rx_normal", restart_CS)) then ! do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ! OBC%rx_normal(I,j,k) = vel_rescale * OBC%rx_normal(I,j,k) @@ -1837,8 +1757,8 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) ! The oblique boundary condition terms have units of [L2 T-2 ~> m2 s-2] and may need to be rescaled. if ( OBC%oblique_BCs_exist_globally .and. (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel2_rescale = (US%m_to_L * US%s_to_T_restart)**2 / (US%m_to_L_restart * US%s_to_T)**2 + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel2_rescale = US%s_to_T_restart**2 / US%m_to_L_restart**2 if (query_initialized(OBC%rx_oblique, "rx_oblique", restart_CS)) then do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB OBC%rx_oblique(I,j,k) = vel2_rescale * OBC%rx_oblique(I,j,k) @@ -3490,7 +3410,6 @@ subroutine allocate_OBC_segment_data(OBC, segment) integer :: isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB integer :: IscB, IecB, JscB, JecB - character(len=40) :: mdl = "allocate_OBC_segment_data" ! This subroutine's name. isd = segment%HI%isd ; ied = segment%HI%ied jsd = segment%HI%jsd ; jed = segment%HI%jed @@ -3576,8 +3495,6 @@ end subroutine allocate_OBC_segment_data !> Deallocate segment data fields subroutine deallocate_OBC_segment_data(segment) type(OBC_segment_type), intent(inout) :: segment !< Open boundary segment - ! Local variables - character(len=40) :: mdl = "deallocate_OBC_segment_data" ! This subroutine's name. if (.not. segment%on_pe) return @@ -3709,14 +3626,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! Local variables integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB, n, m, nz - character(len=40) :: mdl = "update_OBC_segment_data" ! This subroutine's name. - character(len=200) :: filename, OBC_file, inputdir ! Strings for file/path type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] integer :: ni_seg, nj_seg ! number of src gridpoints along the segments integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer - integer :: i2, j2 ! indices for referencing local domain array integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] @@ -3730,6 +3644,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] + real :: h_neglect, h_neglect_edge ! Small thicknesses [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3742,6 +3657,14 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) + if (.not. OBC%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3940,7 +3863,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! no dz for tidal variables if (segment%field(m)%nk_src > 1 .and.& (index(segment%field(m)%name, 'phase') <= 0 .and. index(segment%field(m)%name, 'amp') <= 0)) then - call time_interp_external(segment%field(m)%fid_dz,Time, tmp_buffer_in) + call time_interp_external(segment%field(m)%fid_dz, Time, tmp_buffer_in) + tmp_buffer_in(:,:,:) = tmp_buffer_in(:,:,:) * US%m_to_Z if (turns /= 0) then ! TODO: This is hardcoded for 90 degrees, and needs to be generalized. if (segment%is_E_or_W & @@ -4006,19 +3930,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) elseif (G%mask2dCu(I,j)>0.) then h_stack(:) = h(i+ishift,j,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) elseif (G%mask2dCu(I,j+1)>0.) then h_stack(:) = h(i+ishift,j+1,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) endif enddo else @@ -4033,7 +3960,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & - GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:)) + GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & + h_neglect, h_neglect_edge) endif enddo endif @@ -4052,19 +3980,22 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) elseif (G%mask2dCv(i,J)>0.) then h_stack(:) = h(i,j+jshift,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) elseif (G%mask2dCv(i+1,J)>0.) then h_stack(:) = h(i+1,j+jshift,:) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:)) + GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & + h_neglect, h_neglect_edge) endif enddo else @@ -4079,7 +4010,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) call remapping_core_h(OBC%remap_CS, & segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & - GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:)) + GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & + h_neglect, h_neglect_edge) endif enddo endif @@ -4413,7 +4345,6 @@ subroutine OBC_registry_init(param_file, Reg) integer, save :: init_calls = 0 # include "version_variable.h" - character(len=40) :: mdl = "MOM_open_boundary" ! This module's name. character(len=256) :: mesg ! Message for error messages. if (.not.associated(Reg)) then ; allocate(Reg) @@ -4472,7 +4403,7 @@ subroutine segment_tracer_registry_init(param_file, segment) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "segment_tracer_registry_init" ! This routine's name. - character(len=256) :: mesg ! Message for error messages. + !character(len=256) :: mesg ! Message for error messages. if (.not.associated(segment%tr_Reg)) then allocate(segment%tr_Reg) @@ -4579,11 +4510,10 @@ subroutine register_temp_salt_segments(GV, OBC, tr_Reg, param_file) type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf - integer :: i, j, k, n - character(len=32) :: name + integer :: n + character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - type(tracer_type), pointer :: tr_ptr => NULL() + type(tracer_type), pointer :: tr_ptr => NULL() if (.not. associated(OBC)) return @@ -4675,14 +4605,12 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n integer :: i, j integer :: l_seg logical :: fatal_error = .False. real :: min_depth ! The minimum depth for ocean points [Z ~> m] integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 character(len=256) :: mesg ! Message for error messages. - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, ! two different ways @@ -4777,7 +4705,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) if (color(i,j) /= color2(i,j)) then fatal_error = .True. write(mesg,'("MOM_open_boundary: problem with OBC segments specification at ",I5,",",I5," during\n", & - "the masking of the outside grid points.")') i, j + &"the masking of the outside grid points.")') i, j call MOM_error(WARNING,"MOM register_tracer: "//mesg, all_print=.true.) endif if (color(i,j) == cout) G%bathyT(i,j) = min_depth @@ -4910,10 +4838,11 @@ subroutine flood_fill2(G, color, cin, cout, cland) end subroutine flood_fill2 !> Register OBC segment data for restarts -subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart_CS, & +subroutine open_boundary_register_restarts(HI, GV, US, OBC, Reg, param_file, restart_CS, & use_temperature) type(hor_index_type), intent(in) :: HI !< Horizontal indices type(verticalGrid_type), pointer :: GV !< Container for vertical grid information + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ocean_OBC_type), pointer :: OBC !< OBC data structure, data intent(inout) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(param_file_type), intent(in) :: param_file !< Parameter file handle @@ -4921,26 +4850,31 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables type(vardesc) :: vd(2) - integer :: m, n - character(len=100) :: mesg - type(OBC_segment_type), pointer :: segment=>NULL() + integer :: m + character(len=100) :: mesg, var_name if (.not. associated(OBC)) & call MOM_error(FATAL, "open_boundary_register_restarts: Called with "//& "uninitialized OBC control structure") - ! *** This is a temporary work around for restarts with OBC segments. + ! ### This is a temporary work around for restarts with OBC segments. ! This implementation uses 3D arrays solely for restarts. We need ! to be able to add 2D ( x,z or y,z ) data to restarts to avoid using - ! so much memory and disk space. *** + ! so much memory and disk space. if (OBC%radiation_BCs_exist_globally) then allocate(OBC%rx_normal(HI%isdB:HI%iedB,HI%jsd:HI%jed,GV%ke), source=0.0) allocate(OBC%ry_normal(HI%isd:HI%ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') - vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), & - .false., restart_CS) + vd(1) = var_desc("rx_normal", "gridpoint timestep-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + vd(2) = var_desc("ry_normal", "gridpoint timestep-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS) + ! The rx_normal and ry_normal arrays used with radiation OBCs are currently in units of grid + ! points per timestep, but if this were to be corrected to [L T-1 ~> m s-1] or [T-1 ~> s-1] to + ! permit timesteps to change between calls to the OBC code, the following would be needed instead: + ! vd(1) = var_desc("rx_normal", "m s-1", "Normal Phase Speed for EW radiation OBCs", 'u', 'L') + ! vd(2) = var_desc("ry_normal", "m s-1", "Normal Phase Speed for NS radiation OBCs", 'v', 'L') + ! call register_restart_pair(OBC%rx_normal, OBC%ry_normal, vd(1), vd(2), .false., restart_CS, & + ! conversion=US%L_T_to_m_s) endif if (OBC%oblique_BCs_exist_globally) then @@ -4949,12 +4883,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart vd(1) = var_desc("rx_oblique", "m2 s-2", "Radiation Speed Squared for EW oblique OBCs", 'u', 'L') vd(2) = var_desc("ry_oblique", "m2 s-2", "Radiation Speed Squared for NS oblique OBCs", 'v', 'L') - call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), & - .false., restart_CS) + call register_restart_pair(OBC%rx_oblique, OBC%ry_oblique, vd(1), vd(2), .false., & + restart_CS, conversion=US%L_T_to_m_s**2) allocate(OBC%cff_normal(HI%IsdB:HI%IedB,HI%jsdB:HI%jedB,GV%ke), source=0.0) - vd(1) = var_desc("cff_normal", "m2 s-2", "denominator for oblique OBCs", 'q', 'L') - call register_restart_field(OBC%cff_normal, vd(1), .false., restart_CS) + call register_restart_field(OBC%cff_normal, "cff_normal", .false., restart_CS, & + longname="denominator for oblique OBCs", & + units="m2 s-2", conversion=US%L_T_to_m_s**2, hor_grid="q") endif if (Reg%ntr == 0) return @@ -4978,13 +4913,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_x_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') else - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_x(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_x(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') endif endif enddo @@ -4994,13 +4929,13 @@ subroutine open_boundary_register_restarts(HI, GV, OBC, Reg, param_file, restart do m=1,OBC%ntr if (OBC%tracer_y_reservoirs_used(m)) then if (modulo(HI%turns, 2) /= 0) then - write(mesg,'("tres_x_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for EW OBCs",'u','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_x_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for EW OBCs", units="Conc", hor_grid='u') else - write(mesg,'("tres_y_",I3.3)') m - vd(1) = var_desc(mesg,"Conc", "Tracer concentration for NS OBCs",'v','L') - call register_restart_field(OBC%tres_y(:,:,:,m), vd(1), .false., restart_CS) + write(var_name,'("tres_y_",I3.3)') m + call register_restart_field(OBC%tres_y(:,:,:,m), var_name, .false., restart_CS, & + longname="Tracer concentration for NS OBCs", units="Conc", hor_grid='v') endif endif enddo @@ -5104,11 +5039,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) integer, intent(in) :: fld !< field index to adjust thickness integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - integer :: n real, allocatable, dimension(:,:,:) :: eta ! Segment source data interface heights [Z ~> m] real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] ! real :: dilate ! A factor by which to dilate the water column [nondim] - character(len=100) :: mesg + !character(len=100) :: mesg hTolerance = 0.1*US%m_to_Z @@ -5442,7 +5376,6 @@ subroutine rotate_OBC_segment_data(segment_in, segment, turns) integer, intent(in) :: turns integer :: n - integer :: is, ie, js, je, nk integer :: num_fields diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index d23509d5f6..e807f19484 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -48,7 +48,7 @@ subroutine por_widths(h, tv, G, GV, US, eta, pbv, eta_bt, halo_size, eta_to_m) type(porous_barrier_ptrs), intent(inout) :: pbv !< porous barrier fractional cell metrics !local variables - integer ii, i, j, k, nk, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + integer i, j, k, nk, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB real w_layer, & ! fractional open width of layer interface [nondim] A_layer, & ! integral of fractional open width from bottom to current layer[Z ~> m] A_layer_prev, & ! integral of fractional open width from bottom to previous layer [Z ~> m] diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index a9bf6c3dcf..7cdf3e8e71 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -441,9 +441,8 @@ subroutine deallocate_surface_state(sfc_state) end subroutine deallocate_surface_state !> Rotate the surface state fields from the input to the model indices. -subroutine rotate_surface_state(sfc_state_in, G_in, sfc_state, G, turns) +subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) type(surface), intent(in) :: sfc_state_in - type(ocean_grid_type), intent(in) :: G_in type(surface), intent(inout) :: sfc_state type(ocean_grid_type), intent(in) :: G integer, intent(in) :: turns diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index b856cff3dc..2df65f09aa 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -142,7 +142,7 @@ subroutine verticalGridInit( param_file, GV, US ) ! Here NK_ is a macro, while nk is a variable. call get_param(param_file, mdl, "NK", nk, & "The number of model layers.", units="nondim", & - static_value=NK_) + default=NK_) if (nk /= NK_) call MOM_error(FATAL, "verticalGridInit: " // & "Mismatched number of layers NK_ between MOM_memory.h and param_file") @@ -188,10 +188,17 @@ subroutine verticalGridInit( param_file, GV, US ) end subroutine verticalGridInit !> Set the scaling factors for restart files to the scaling factors for this run. -subroutine fix_restart_scaling(GV) +subroutine fix_restart_scaling(GV, unscaled) type(verticalGrid_type), intent(inout) :: GV !< The ocean's vertical grid structure + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. GV%m_to_H_restart = GV%m_to_H + if (present(unscaled)) then ; if (unscaled) then + GV%m_to_H_restart = 1.0 + endif ; endif + end subroutine fix_restart_scaling !> Returns the model's thickness units, usually m or kg/m^2. diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index a4badaf8e7..e52feec697 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -147,7 +147,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st call get_time((CS%Time - set_date(yr, 1, 1, 0, 0, 0)), sec, yearday) write (file,'(/,"--------------------------")') write (file,'(/,"Time ",i5,i4,F6.2," U-velocity violation at ",I4,": ",2(I3), & - & " (",F7.2," E "F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & + & " (",F7.2," E ",F7.2," N) Layers ",I3," to ",I3,". dt = ",1PG10.4)') & yr, yearday, (REAL(sec)/3600.0), pe_here(), I, j, & G%geoLonCu(I,j), G%geoLatCu(I,j), ks, ke, US%T_to_s*dt @@ -156,174 +156,174 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i+1,j,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"u(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*um(I,j,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"u(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*um(I,j,k)) ; enddo if (prev_avail) then - write(file,'(/,"u(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_prev(I,j,k)) ; enddo + write(file,'(/,"u(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_prev(I,j,k)) ; enddo endif - write(file,'(/,"u(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%u_av(I,j,k)) ; enddo + write(file,'(/,"u(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%u_av(I,j,k)) ; enddo - write(file,'(/,"CFL u: ",$)') + write(file,'(/,"CFL u: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(um(I,j,k)) * dt * G%dy_Cu(I,j) if (um(I,j,k) < 0.0) then ; CFL = CFL * G%IareaT(i+1,j) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 u:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 u:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(um(I,j,k)) * dt * G%IdxCu(I,j) ; enddo if (prev_avail) then - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(um(I,j,k)-CS%u_prev(I,j,k))) ; enddo endif - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAu(I,j,k)) ; enddo + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFu(I,j,k)) ; enddo + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffu(I,j,k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEu(I,j,k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"ubv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"ubv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(um(I,j,k) - dt*ADp%du_dt_visc(I,j,k)) ; enddo - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%du_dt_visc(I,j,k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%du_other(I,j,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(I,j,k)*dt) ; enddo + write(file,'(/,"a: ")', advance='no') + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(I,j,k)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(I,j,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(I,j,k) ; enddo endif write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%u_accel_bt)) then - write(file,'("dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'("dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%u_accel_bt(I,j,k)) ; enddo write(file,'(/)') endif - write(file,'(/,"h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j-1,k)) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j-1,k)) ; enddo - write(file,'(/,"h-0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j,k)) ; enddo - write(file,'(/,"h+0: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j,k)) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i,j+1,k)) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (h_scale*hin(i+1,j+1,k)) ; enddo + write(file,'(/,"h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j-1,k)) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j-1,k)) ; enddo + write(file,'(/,"h-0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j,k)) ; enddo + write(file,'(/,"h+0: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j,k)) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i,j+1,k)) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (h_scale*hin(i+1,j+1,k)) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i+1,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i+1,j,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i+1,j,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i+1,j,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i+1,j,k) ; enddo endif if (prev_avail) then - write(file,'(/,"v--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo - write(file,'(/,"v-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo - write(file,'(/,"v+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo - write(file,'(/,"v++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo - endif - - write(file,'(/,"vh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"v--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J-1,k)) ; enddo + write(file,'(/,"v-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J-1,k)) ; enddo + write(file,'(/,"v++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i+1,J,k)) ; enddo + endif + + write(file,'(/,"vh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J-1,k)*G%IdxCv(i,J-1)) ; enddo - write(file,'(/," vhC--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,j-1,k)*uh_scale*(hin(i,j-1,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"vh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i,J,k)*G%IdxCv(i,J)) ; enddo - write(file,'(/," vhC-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i,J,k)*uh_scale*(hin(i,j,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"vh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J-1,k)*G%IdxCv(i+1,J-1)) ; enddo - write(file,'(/," vhC+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_prev(i+1,J-1,k)*uh_scale*(hin(i+1,j-1,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"vh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%vh(i+1,J,k)*G%IdxCv(i+1,J)) ; enddo - write(file,'(/," vhC++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhC++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," vhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," vhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (0.5*CS%v_av(i+1,J,k)*uh_scale*(hin(i+1,j,k) + hin(i+1,j+1,k))) ; enddo endif @@ -337,48 +337,48 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / du enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"du: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((um(I,j,k)-CS%u_prev(I,j,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"PFu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFu(I,j,k) * Inorm(k)) ; enddo - write(file,'(/,"diffu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffu(I,j,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEu: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEu: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEu(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_v)) then - write(file,'(/,"Coru: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Coru: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAu(I,j,k)-ADp%rv_x_v(I,j,k)) * Inorm(k)) ; enddo endif if (associated(ADp%du_dt_visc)) then - write(file,'(/,"duv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"duv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%du_dt_visc(I,j,k) * Inorm(k)) ; enddo endif if (associated(ADp%du_other)) then - write(file,'(/,"du_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"du_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%du_other(I,j,k) * Inorm(k)) ; enddo endif if (associated(CS%u_accel_bt)) then - write(file,'(/,"dubt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dubt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%u_accel_bt(I,j,k) * Inorm(k)) ; enddo endif endif @@ -487,178 +487,178 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st if ((hin(i,j,k) + hin(i,j+1,k)) > 3.0*Angstrom) do_k(k) = .true. enddo - write(file,'(/,"Layers:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(I10," ",$)') (k) ; enddo - write(file,'(/,"v(m): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*vm(i,J,k)) ; enddo + write(file,'(/,"Layers:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(I10," ")', advance='no') (k) ; enddo + write(file,'(/,"v(m): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*vm(i,J,k)) ; enddo if (prev_avail) then - write(file,'(/,"v(mp): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_prev(i,J,k)) ; enddo + write(file,'(/,"v(mp): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_prev(i,J,k)) ; enddo endif - write(file,'(/,"v(3): ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*CS%v_av(i,J,k)) ; enddo - write(file,'(/,"CFL v: ",$)') + write(file,'(/,"v(3): ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*CS%v_av(i,J,k)) ; enddo + write(file,'(/,"CFL v: ")', advance='no') do k=ks,ke ; if (do_k(k)) then CFL = abs(vm(i,J,k)) * dt * G%dx_Cv(i,J) if (vm(i,J,k) < 0.0) then ; CFL = CFL * G%IareaT(i,j+1) else ; CFL = CFL * G%IareaT(i,j) ; endif - write(file,'(ES10.3," ",$)') CFL + write(file,'(ES10.3," ")', advance='no') CFL endif ; enddo - write(file,'(/,"CFL0 v:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"CFL0 v:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & abs(vm(i,J,k)) * dt * G%IdyCv(i,J) ; enddo if (prev_avail) then - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*(vm(i,J,k)-CS%v_prev(i,J,k))) ; enddo endif - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%CAv(i,J,k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%PFv(i,J,k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (vel_scale*dt*ADp%diffv(i,J,k)) ; enddo if (associated(ADp%gradKEv)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%gradKEv(i,J,k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"vbv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"vbv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & vel_scale*(vm(i,J,k) - dt*ADp%dv_dt_visc(i,J,k)) ; enddo - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*ADp%dv_dt_visc(i,J,k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*ADp%dv_other(i,J,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",$)') - do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ",$)') (US%Z_to_m*a(i,j,k)*dt) ; enddo + write(file,'(/,"a: ")', advance='no') + do k=ks,ke+1 ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(i,j,k)*dt) ; enddo endif if (present(hv)) then - write(file,'(/,"hvel: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hv(i,J,k) ; enddo + write(file,'(/,"hvel: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(i,J,k) ; enddo endif write(file,'(/,"Stress: ",ES10.3)') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) if (associated(CS%v_accel_bt)) then - write(file,'("dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'("dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (vel_scale*dt*CS%v_accel_bt(i,J,k)) ; enddo write(file,'(/)') endif - write(file,'("h--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j,k) ; enddo - write(file,'(/,"h0-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j,k) ; enddo - write(file,'(/,"h+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j,k) ; enddo - write(file,'(/,"h-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i-1,j+1,k) ; enddo - write(file,'(/,"h0+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"h++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') h_scale*hin(i+1,j+1,k) ; enddo + write(file,'("h--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j,k) ; enddo + write(file,'(/,"h0-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j,k) ; enddo + write(file,'(/,"h+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j,k) ; enddo + write(file,'(/,"h-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i-1,j+1,k) ; enddo + write(file,'(/,"h0+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i,j+1,k) ; enddo + write(file,'(/,"h++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hin(i+1,j+1,k) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j,k) ; enddo - write(file,'(/,"e-: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e-: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo e(nz+1) = -US%Z_to_m*(G%bathyT(i,j+1) + G%Z_ref) do k=nz,1,-1 ; e(K) = e(K+1) + h_scale*hin(i,j+1,k) ; enddo - write(file,'(/,"e+: ",$)') - write(file,'(ES10.3," ",$)') e(ks) - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ",$)') e(K) ; enddo + write(file,'(/,"e+: ")', advance='no') + write(file,'(ES10.3," ")', advance='no') e(ks) + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') e(K) ; enddo if (associated(CS%T)) then - write(file,'(/,"T-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j,k) ; enddo - write(file,'(/,"T+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%T(i,j+1,k) ; enddo + write(file,'(/,"T-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j,k) ; enddo + write(file,'(/,"T+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%T(i,j+1,k) ; enddo endif if (associated(CS%S)) then - write(file,'(/,"S-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j,k) ; enddo - write(file,'(/,"S+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') CS%S(i,j+1,k) ; enddo + write(file,'(/,"S-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j,k) ; enddo + write(file,'(/,"S+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') CS%S(i,j+1,k) ; enddo endif if (prev_avail) then - write(file,'(/,"u--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j,k) ; enddo - write(file,'(/,"u-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo - write(file,'(/,"u+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j,k) ; enddo - write(file,'(/,"u++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') vel_scale*CS%u_prev(I,j+1,k) ; enddo - endif - - write(file,'(/,"uh--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"u--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j,k) ; enddo + write(file,'(/,"u-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I-1,j+1,k) ; enddo + write(file,'(/,"u+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j,k) ; enddo + write(file,'(/,"u++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') vel_scale*CS%u_prev(I,j+1,k) ; enddo + endif + + write(file,'(/,"uh--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j,k)*G%IdyCu(I-1,j)) ; enddo - write(file,'(/," uhC--: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC--: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp--:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp--:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j,k) * uh_scale*0.5*(hin(i-1,j,k) + hin(i,j,k))) ; enddo endif - write(file,'(/,"uh-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I-1,j+1,k)*G%IdyCu(I-1,j+1)) ; enddo - write(file,'(/," uhC-+: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC-+: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp-+:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp-+:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I-1,j+1,k) * uh_scale*0.5*(hin(i-1,j+1,k) + hin(i,j+1,k))) ; enddo endif - write(file,'(/,"uh+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j,k)*G%IdyCu(I,j)) ; enddo - write(file,'(/," uhC+-: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC+-: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp+-:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp+-:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j,k) * uh_scale*0.5*(hin(i,j,k) + hin(i+1,j,k))) ; enddo endif - write(file,'(/,"uh++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/,"uh++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (uh_scale*CDp%uh(I,j+1,k)*G%IdyCu(I,j+1)) ; enddo - write(file,'(/," uhC++: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhC++: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_av(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo if (prev_avail) then - write(file,'(/," uhCp++:",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ",$)') & + write(file,'(/," uhCp++:")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') & (CS%u_prev(I,j+1,k) * uh_scale*0.5*(hin(i,j+1,k) + hin(i+1,j+1,k))) ; enddo endif @@ -672,44 +672,44 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st Inorm(k) = 1.0 / dv enddo - write(file,'(2/,"Norm: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') (vel_scale / Inorm(k)) ; enddo - write(file,'(/,"dv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(2/,"Norm: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') (vel_scale / Inorm(k)) ; enddo + write(file,'(/,"dv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & ((vm(i,J,k)-CS%v_prev(i,J,k)) * Inorm(k)) ; enddo - write(file,'(/,"CAv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"CAv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%CAv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"PFv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"PFv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%PFv(i,J,k) * Inorm(k)) ; enddo - write(file,'(/,"diffv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"diffv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%diffv(i,J,k) * Inorm(k)) ; enddo if (associated(ADp%gradKEu)) then - write(file,'(/,"KEv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"KEv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%gradKEv(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%rv_x_u)) then - write(file,'(/,"Corv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"Corv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*(ADp%CAv(i,J,k)-ADp%rv_x_u(i,J,k)) * Inorm(k)) ; enddo endif if (associated(ADp%dv_dt_visc)) then - write(file,'(/,"dvv: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvv: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*ADp%dv_dt_visc(i,J,k) * Inorm(k)) ; enddo endif if (associated(ADp%dv_other)) then - write(file,'(/,"dv_other: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dv_other: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (ADp%dv_other(i,J,k) * Inorm(k)) ; enddo endif if (associated(CS%v_accel_bt)) then - write(file,'(/,"dvbt: ",$)') - do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ",$)') & + write(file,'(/,"dvbt: ")', advance='no') + do k=ks,ke ; if (do_k(k)) write(file,'(F10.6," ")', advance='no') & (dt*CS%v_accel_bt(i,J,k) * Inorm(k)) ; enddo endif endif diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index fda5a97d69..fd7e891e82 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -196,7 +196,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -386,7 +386,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_resym(i,j) /= v_comp(i,j) .and. & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) @@ -435,7 +435,7 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch - integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed + integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed is_ch = G%isc ; ie_ch = G%iec ; js_ch = G%jsc ; je_ch = G%jec @@ -549,7 +549,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (v_nonsym(i,j) /= v_comp(i,j) .and. & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & - & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)" on pe ",i4)') & + & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & v_comp(i,j), v_nonsym(i,j),v_comp(i,j)-v_nonsym(i,j),i,j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 8d667503d7..9c22ab5eb5 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -234,9 +234,6 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! This value is roughly (pi / (the age of the universe) )^2. absurdly_small_freq2 = 1e-34*US%T_to_s**2 - if (loc(CS)==0) call MOM_error(FATAL, & - "calculate_diagnostic_fields: Module must be initialized before used.") - if (.not. CS%initialized) call MOM_error(FATAL, & "calculate_diagnostic_fields: Module must be initialized before used.") @@ -455,7 +452,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! area mean SSS if (CS%id_sosga > 0) then do j=js,je ; do i=is,ie - surface_field(i,j) = tv%S(i,j,1) + surface_field(i,j) = tv%S(i,j,1) enddo ; enddo sosga = global_area_mean(surface_field, G) call post_data(CS%id_sosga, sosga, CS%diag) @@ -1293,32 +1290,27 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array real, dimension(SZI_(G),SZJ_(G)) :: & - zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [m] + zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [Z ~> m] real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. - real :: zos_area_mean ! Global area mean sea surface height [m] + real :: zos_area_mean ! Global area mean sea surface height [Z ~> m] real :: volo ! Total volume of the ocean [m3] - real :: ssh_ga ! Global ocean area weighted mean sea seaface height [m] + real :: ssh_ga ! Global ocean area weighted mean sea seaface height [Z ~> m] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ! area mean SSH if (IDs%id_ssh_ga > 0) then - ssh_ga = global_area_mean(ssh, G, scale=US%Z_to_m) + ssh_ga = global_area_mean(ssh, G, tmp_scale=US%Z_to_m) call post_data(IDs%id_ssh_ga, ssh_ga, diag) endif ! post the dynamic sea level, zos, and zossq. - ! zos is ave_ssh with sea ice inverse barometer removed, - ! and with zero global area mean. + ! zos is ave_ssh with sea ice inverse barometer removed, and with zero global area mean. if (IDs%id_zos > 0 .or. IDs%id_zossq > 0) then - zos(:,:) = 0.0 - do j=js,je ; do i=is,ie - zos(i,j) = US%Z_to_m*ssh_ibc(i,j) - enddo ; enddo - zos_area_mean = global_area_mean(zos, G) + zos_area_mean = global_area_mean(ssh_ibc, G, tmp_scale=US%Z_to_m) do j=js,je ; do i=is,ie - zos(i,j) = zos(i,j) - G%mask2dT(i,j)*zos_area_mean + zos(i,j) = ssh_ibc(i,j) - G%mask2dT(i,j)*zos_area_mean enddo ; enddo if (IDs%id_zos > 0) call post_data(IDs%id_zos, zos, diag, mask=G%mask2dT) if (IDs%id_zossq > 0) then @@ -1844,14 +1836,14 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) standard_name='sea_water_volume') IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& standard_name = 'sea_surface_height_above_geoid', & - long_name= 'Sea surface height above geoid', units='m') + long_name= 'Sea surface height above geoid', units='m', conversion=US%Z_to_m) IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& standard_name='square_of_sea_surface_height_above_geoid', & - long_name='Square of sea surface height above geoid', units='m2') + long_name='Square of sea surface height above geoid', units='m2', conversion=US%Z_to_m**2) IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & 'Sea Surface Height', 'm', conversion=US%Z_to_m) IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& - long_name='Area averaged sea surface height', units='m', & + long_name='Area averaged sea surface height', units='m', conversion=US%Z_to_m, & standard_name='area_averaged_sea_surface_height') IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & 'Sea Surface Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) diff --git a/src/diagnostics/MOM_obsolete_diagnostics.F90 b/src/diagnostics/MOM_obsolete_diagnostics.F90 index 86034292b5..ddfe0452a0 100644 --- a/src/diagnostics/MOM_obsolete_diagnostics.F90 +++ b/src/diagnostics/MOM_obsolete_diagnostics.F90 @@ -64,8 +64,6 @@ logical function diag_found(diag, varName, newVarName) type(diag_ctrl), intent(in) :: diag !< A structure used to control diagnostics. character(len=*), intent(in) :: varName !< The obsolete diagnostic name character(len=*), optional, intent(in) :: newVarName !< The valid name of this diagnostic - ! Local - integer :: handle ! Integer handle returned from diag_manager diag_found = found_in_diagtable(diag, varName) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index dfadaa1da5..e0441cac2e 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -23,8 +23,8 @@ subroutine find_obsolete_params(param_file) character(len=40) :: mdl = "find_obsolete_params" ! This module's name. ! This include declares and sets the variable "version". #include "version_variable.h" - integer :: test_int, l_seg, nseg - logical :: test_logic, test_logic2, test_logic3, split + integer :: l_seg, nseg + logical :: test_logic, split character(len=40) :: temp_string if (.not.is_root_pe()) return @@ -93,6 +93,9 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") + ! This parameter is on the to-do list to be obsoleted. + ! call obsolete_logical(param_file, "NEW_SPONGES", hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 7969ee11f8..551b821645 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -19,95 +19,127 @@ module MOM_spatial_means public :: global_i_mean, global_j_mean public :: global_area_mean, global_area_mean_u, global_area_mean_v, global_layer_mean public :: global_area_integral -public :: global_volume_mean, global_mass_integral +public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero contains !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean(var, G, scale) +function global_area_mean(var, G, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average real, optional, intent(in) :: scale !< A rescaling factor for the variable - - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_area_mean + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo + global_area_mean = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean = global_area_mean / temp_scale + end function global_area_mean !> Return the global area mean of a variable. This uses reproducing sums. -function global_area_mean_v(var, G) +function global_area_mean_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJB_(G)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: global_area_mean_v + + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming + real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + tmpForSumming(:,:) = 0. do J=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * (var(i,J) * G%mask2dCv(i,J) + & - var(i,J-1) * G%mask2dCv(i,J-1)) & - / max(1.e-20,G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(i,J) * G%mask2dCv(i,J) + var(i,J-1) * G%mask2dCv(i,J-1)) / & + max(1.e-20, G%mask2dCv(i,J)+G%mask2dCv(i,J-1)) enddo ; enddo global_area_mean_v = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_v = global_area_mean_v / temp_scale end function global_area_mean_v !> Return the global area mean of a variable on U grid. This uses reproducing sums. -function global_area_mean_u(var, G) +function global_area_mean_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G), SZJ_(G)), intent(in) :: var !< The variable to average + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value + real :: global_area_mean_u real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: global_area_mean_u + real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale + tmpForSumming(:,:) = 0. do j=js,je ; do i=is,ie - tmpForSumming(i,j) = G%areaT(i,j) * (var(I,j) * G%mask2dCu(I,j) + & - var(I-1,j) * G%mask2dCu(I-1,j)) & - / max(1.e-20,G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) + tmpForSumming(i,j) = G%areaT(i,j) * scalefac * & + (var(I,j) * G%mask2dCu(I,j) + var(I-1,j) * G%mask2dCu(I-1,j)) / & + max(1.e-20, G%mask2dCu(I,j)+G%mask2dCu(I-1,j)) enddo ; enddo global_area_mean_u = reproducing_sum(tmpForSumming) * G%IareaT_global + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_mean_u = global_area_mean_u / temp_scale end function global_area_mean_u !> Return the global area integral of a variable, by default using the masked area from the !! grid, but an alternate could be used instead. This uses reproducing sums. -function global_area_integral(var, G, scale, area) +function global_area_integral(var, G, scale, area, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate real, optional, intent(in) :: scale !< A rescaling factor for the variable real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including - !! any required masking [L2 ~> m2]. + !! any required masking [L2 ~> m2]. + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0. if (present(area)) then @@ -119,27 +151,35 @@ function global_area_integral(var, G, scale, area) tmpForSumming(i,j) = var(i,j) * (scalefac * G%areaT(i,j) * G%mask2dT(i,j)) enddo ; enddo endif + global_area_integral = reproducing_sum(tmpForSumming) + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_area_integral = global_area_integral / temp_scale + end function global_area_integral !> Return the layerwise global thickness-weighted mean of a variable. This uses reproducing sums. -function global_layer_mean(var, h, G, GV, scale) +function global_layer_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real, dimension(SZK_(GV)) :: global_layer_mean real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight type(EFP_type), dimension(2*SZK_(GV)) :: laysums real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar + real :: temp_scale ! A temporary scaling factor real :: scalefac ! A scaling factor for the variable. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = scale * temp_scale tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -152,13 +192,13 @@ function global_layer_mean(var, h, G, GV, scale) call EFP_sum_across_PEs(laysums, 2*nz) do k=1,nz - global_layer_mean(k) = EFP_to_real(laysums(k)) / EFP_to_real(laysums(nz+k)) + global_layer_mean(k) = EFP_to_real(laysums(k)) / (temp_scale * EFP_to_real(laysums(nz+k))) enddo end function global_layer_mean !> Find the global thickness-weighted mean of a variable. This uses reproducing sums. -function global_volume_mean(var, h, G, GV, scale) +function global_volume_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -166,15 +206,19 @@ function global_volume_mean(var, h, G, GV, scale) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_volume_mean !< The thickness-weighted average of var + real :: temp_scale ! A temporary scaling factor real :: scalefac ! A scaling factor for the variable. real :: weight_here real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming, sum_weight integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = 1.0 ; if (present(scale)) scalefac = scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = temp_scale ; if (present(scale)) scalefac = temp_scale * scale tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie @@ -183,13 +227,13 @@ function global_volume_mean(var, h, G, GV, scale) sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo global_volume_mean = (reproducing_sum(tmpForSumming)) / & - (reproducing_sum(sum_weight)) + (temp_scale * reproducing_sum(sum_weight)) end function global_volume_mean !> Find the global mass-weighted integral of a variable. This uses reproducing sums. -function global_mass_integral(h, G, GV, var, on_PE_only, scale) +function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -199,16 +243,20 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only !! done on the local PE, and it is _not_ order invariant. real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the return value real :: global_mass_integral !< The mass-weighted integral of var (or 1) in !! kg times the units of var real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming real :: scalefac ! An overall scaling factor for the areas and variable. + real :: temp_scale ! A temporary scaling factor. logical :: global_sum integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - scalefac = G%US%L_to_m**2 ; if (present(scale)) scalefac = G%US%L_to_m**2*scale + temp_scale = 1.0 ; if (present(tmp_scale)) temp_scale = tmp_scale + scalefac = G%US%L_to_m**2*temp_scale ; if (present(scale)) scalefac = scalefac * scale tmpForSumming(:,:) = 0.0 if (present(var)) then @@ -232,8 +280,54 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale) enddo ; enddo endif + if ((temp_scale /= 0.0) .and. (temp_scale /= 1.0)) & + global_mass_integral = global_mass_integral / temp_scale + end function global_mass_integral +!> Find the global mass-weighted order invariant integral of a variable in mks units, +!! returning the value as an EFP_type. This uses reproducing sums. +function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: var !< The variable being integrated + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, but it is still order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable + type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in + !! kg times the units of var + + ! Local variables + real, dimension(SZI_(G), SZJ_(G)) :: tmpForSum + real :: scalefac ! An overall scaling factor for the areas and variable. + integer :: i, j, k, is, ie, js, je, nz, isr, ier, jsr, jer + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + scalefac = GV%H_to_kg_m2 * G%US%L_to_m**2 + if (present(scale)) scalefac = scale * scalefac + + tmpForSum(:,:) = 0.0 + if (present(var)) then + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + var(i,j,k) * & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + else + do k=1,nz ; do j=js,je ; do i=is,ie + tmpForSum(i,j) = tmpForSum(i,j) + & + ((scalefac * h(i,j,k)) * (G%areaT(i,j) * G%mask2dT(i,j))) + enddo ; enddo ; enddo + endif + + global_mass_int_EFP = reproducing_sum_EFP(tmpForSum, isr, ier, jsr, jer, only_on_PE=on_PE_only) + +end function global_mass_int_EFP + !> Determine the global mean of a field along rows of constant i, returning it !! in a 1-d array using the local indexing. This uses reproducing sums. diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 668c297658..33f3edcfd4 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -348,16 +348,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: Salt_anom ! The change in salt that cannot be accounted for by ! the surface fluxes [ppt kg]. real :: salin ! The mean salinity of the ocean [ppt]. - real :: salin_chg ! The change in total salt since the last call - ! to this subroutine divided by total mass [ppt]. real :: salin_anom ! The change in total salt that cannot be accounted for by ! the surface fluxes divided by total mass [ppt]. real :: Heat ! The total amount of Heat in the ocean [J]. real :: Heat_chg ! The change in total ocean heat since the last call to this subroutine [J]. real :: Heat_anom ! The change in heat that cannot be accounted for by the surface fluxes [J]. real :: temp ! The mean potential temperature of the ocean [degC]. - real :: temp_chg ! The change in total heat divided by total heat capacity - ! of the ocean since the last call to this subroutine, degC. real :: temp_anom ! The change in total heat that cannot be accounted for ! by the surface fluxes, divided by the total heat ! capacity of the ocean [degC]. @@ -397,7 +393,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! calculation [kg T2 R-1 Z-1 L-2 s-2 ~> 1] integer :: num_nc_fields ! The number of fields that will actually go into ! the NetCDF file. - integer :: i, j, k, is, ie, js, je, ns, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer + integer :: i, j, k, is, ie, js, je, nz, m, Isq, Ieq, Jsq, Jeq, isr, ier, jsr, jer integer :: li, lbelow, labove ! indices of deep_area_vol, used to find Z_0APE. ! lbelow & labove are lower & upper limits for li ! in the search for the entry in lH to use. @@ -733,10 +729,6 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci enddo ; enddo ; enddo call sum_across_PEs(CS%ntrunc) - ! Sum the various quantities across all the processors. This sum is NOT - ! guaranteed to be bitwise reproducible, even on the same decomposition. - ! The sum of Tr_stocks should be reimplemented using the reproducing sums. - if (nTr_stocks > 0) call sum_across_PEs(Tr_stocks,nTr_stocks) call max_across_PEs(max_CFL, 2) @@ -852,13 +844,13 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif do m=1,nTr_stocks - write(stdout,'(" Total ",a,": ",ES24.16,X,a)') & + write(stdout,'(" Total ",a,": ",ES24.16,1X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) if (Tr_minmax_avail(m)) then - write(stdout,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Min:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) - write(stdout,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & + write(stdout,'(64X,"Global Max:",ES24.16,1X,"at: (",f7.2,",",f7.2,",",f8.2,")" )') & Tr_max(m),Tr_max_x(m),Tr_max_y(m),Tr_max_z(m) endif @@ -940,12 +932,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) ! over a time step [ppt kg]. heat_in ! The total heat added by surface fluxes, integrated ! over a time step [J]. - real :: FW_input ! The net fresh water input, integrated over a timestep - ! and summed over space [kg]. - real :: salt_input ! The total salt added by surface fluxes, integrated - ! over a time step and summed over space [ppt kg]. - real :: heat_input ! The total heat added by boundary fluxes, integrated - ! over a time step and summed over space [J]. real :: RZL2_to_kg ! A combination of scaling factors for mass [kg R-1 Z-1 L-2 ~> 1] real :: QRZL2_to_J ! A combination of scaling factors for heat [J Q-1 R-1 Z-1 L-2 ~> 1] @@ -957,7 +943,6 @@ subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) heat_in_EFP ! The total heat added by boundary fluxes, integrated ! over a time step and summed over space [J]. - real :: inputs(3) ! A mixed array for combining the sums integer :: i, j, is, ie, js, je, isr, ier, jsr, jer is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1291,8 +1276,7 @@ subroutine read_depth_list(G, US, DL, filename, require_chksum, file_matches) ! Local variables character(len=240) :: var_msg - real, allocatable :: tmp(:) - integer :: ncid, list_size, k, ndim, sizes(4) + integer :: list_size, ndim, sizes(4) character(len=:), allocatable :: depth_file_chksum, area_file_chksum character(len=16) :: depth_grid_chksum, area_grid_chksum logical :: depth_att_found, area_att_found diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 6765f9aa12..9cb7c46c37 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -103,7 +103,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Rc, & ! A column of layer densities after convective istabilities are removed [R ~> kg m-3] Hc_H ! Hc(:) rescaled from Z to thickness units [H ~> m or kg m-2] real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] - real :: det, ddet, detKm1, detKm2, ddetKm1, ddetKm2 + real :: det, ddet real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] @@ -207,7 +207,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & !$OMP mode_struct,sum_hc,N2min,gp,hw, & !$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & -!$OMP det,ddet,detKm1,ddetKm1,detKm2,ddetKm2,det_it,ddet_it) +!$OMP det,ddet,det_it,ddet_it) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can @@ -262,7 +262,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ endif ! From this point, we can work on individual columns without causing memory to have page faults. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) @@ -722,7 +722,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) logical :: sub_rootfound ! if true, subdivision has located root integer :: kc ! The number of layers in the column after merging integer :: sub, sub_it - integer :: i, j, k, k2, itt, is, ie, js, je, nz, row, iint, m, ig, jg + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -759,7 +759,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) min_h_frac = tol_Hfrac / real(nz) !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,T,S, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP c1_thresh,tol_solve,tol_merge) + !$OMP c1_thresh,tol_solve,tol_merge,c2_scale) do j=js,je ! First merge very thin layers with the one above (or below if they are ! at the top). This also transposes the row order so that columns can @@ -815,7 +815,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! From this point, we can work on individual columns without causing memory to have page faults. do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index c833e973c5..931532983a 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -128,8 +128,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo Hc, & !< A column of layer thicknesses after convective instabilities are removed [Z ~> m] Tc, & !< A column of layer temperatures after convective instabilities are removed [degC] Sc, & !< A column of layer salinites after convective instabilities are removed [ppt] - Rc, & !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] - det, ddet + Rc !< A column of layer densities after convective instabilities are removed [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G)) :: & htot !< The vertical sum of the thicknesses [Z ~> m] real :: lam !< inverse of wave speed squared [T2 L-2 ~> s2 m-2] @@ -141,7 +140,6 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo HxT_here, & !< A layer integrated temperature [degC Z ~> degC m] HxS_here, & !< A layer integrated salinity [ppt Z ~> ppt m] HxR_here !< A layer integrated density [R Z ~> kg m-2] - real :: speed2_tot real :: I_Hnew !< The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum !< The sum of density diffrences across interfaces times thicknesses [R Z ~> kg m-2] real, parameter :: tol1 = 0.0001, tol2 = 0.001 @@ -272,12 +270,12 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo ! From this point, we can work on individual columns without causing memory ! to have page faults. - do i=is,ie ; if (cn(i,j)>0.0)then + do i=is,ie ; if (cn(i,j) > 0.0) then !----for debugging, remove later---- ig = i + G%idg_offset ; jg = j + G%jdg_offset !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then gprime(:) = 0.0 ! init gprime pres(:) = 0.0 ! init pres @@ -567,7 +565,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo !else ! if at test point - delete later ! return ! if at test point - delete later !endif ! if at test point - delete later - endif ! mask2dT > 0.5? + endif ! mask2dT > 0.0? else ! if cn=0.0, default to zero nzm = nz+1! could use actual values @@ -613,7 +611,6 @@ subroutine tridiag_solver(a, b, c, h, y, method, x) ! intermediate values for solvers real :: Q_prime, beta ! intermediate values for solver integer :: k ! row (e.g. interface) index - integer :: i,j nrow = size(y) allocate(c_prime(nrow)) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 39b626985a..80a8d3f866 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -769,7 +769,6 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS ! Local variables real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] - integer :: j p_scale = EOS%RL2_T2_to_Pa @@ -947,7 +946,6 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start type(EOS_type), intent(in) :: EOS !< Equation of state structure ! Local variables - real, dimension(size(T)) :: press ! Pressure converted to [Pa] real, dimension(size(T)) :: rho ! In situ density [kg m-3] real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] @@ -1160,10 +1158,6 @@ subroutine analytic_int_specific_vol_dp(T, S, p_t, p_b, alpha_ref, HI, EOS, & !! the same units as p_t [R L2 T-2 ~> Pa] or [Pa] logical, optional, intent(in) :: useMassWghtInterp !< If true, uses mass weighting !! to interpolate T/S for top and bottom integrals. - ! Local variables - real :: pres_scale ! A unit conversion factor from the rescaled units of pressure to Pa [Pa T2 R-1 L-2 ~> 1] - real :: SV_scale ! A multiplicative factor by which to scale specific - ! volume from m3 kg-1 to the desired units [kg m-3 R-1 ~> 1] ! We should never reach this point with quadrature. EOS_quadrature indicates that numerical ! integration be used instead of analytic. This is a safety check. @@ -1453,8 +1447,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure integer :: i, j, k - real :: gsw_sr_from_sp, gsw_ct_from_pt, gsw_sa_from_sp - real :: p + real :: gsw_sr_from_sp, gsw_ct_from_pt if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 68488881bb..476fda6b70 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -184,8 +184,6 @@ subroutine calculate_density_scalar_nemo(T, S, pressure, rho, rho_ref) real, intent(out) :: rho !< In situ density [kg m-3]. real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - real :: al0, p0, lambda - integer :: j real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: rho0 @@ -212,7 +210,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: zp, zt, zh, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 + real :: zp, zt, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 integer :: j do j=start,start+npts-1 @@ -259,7 +257,7 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re rho(j) = ( zn + zr0 ) ! density endif - enddo + enddo end subroutine calculate_density_array_nemo !> For a given thermodynamic state, calculate the derivatives of density with conservative @@ -276,7 +274,7 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zp,zt , zh , zs , zr0, zn , zn0, zn1, zn2, zn3 + real :: zp, zt, zs, zn, zn0, zn1, zn2, zn3 integer :: j do j=start,start+npts-1 @@ -347,8 +345,6 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1]. ! Local variables - real :: al0, p0, lambda - integer :: j real, dimension(1) :: T0, S0, pressure0 real, dimension(1) :: drdt0, drds0 @@ -391,7 +387,7 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - enddo + enddo end subroutine calculate_compress_nemo end module MOM_EOS_NEMO diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 730687fbf6..8293cf5d32 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -351,7 +351,7 @@ subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: al0, p0, lambda, I_denom + real :: p0, lambda, I_denom integer :: j do j=start,start+npts-1 diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 5ab2874175..c56c397a8d 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -117,8 +117,6 @@ subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - ! Local variables - integer :: j if (present(spv_ref)) then specvol = ((1.0 - Rho_T0_S0*spv_ref) + spv_ref*(dRho_dT*T + dRho_dS*S)) / & diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index 50233cae60..f0b22c8f4e 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -165,7 +165,7 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) - enddo + enddo end subroutine calculate_TFreeze_teos10_array diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index d1a8102fc1..aae3d3f5dc 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -531,7 +531,6 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe !! a scalar, rather than vector - logical :: sym logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in @@ -2196,7 +2195,7 @@ subroutine chk_sum_msg1(fmsg, bc0, mesg, iounit) integer, intent(in) :: iounit !< Checksum logger IO unit if (is_root_pe()) & - write(iounit, '(A,1(A,I10,X),A)') fmsg, " c=", bc0, trim(mesg) + write(iounit, '(a,1(a,i10,1x),a)') fmsg, " c=", bc0, trim(mesg) end subroutine chk_sum_msg1 !> Write a message including checksums of non-shifted and diagonally shifted arrays diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index c3ed3ba7b3..8bf1164a70 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -7,12 +7,14 @@ module MOM_coms use MOM_coms_infra, only : PE_here, root_PE, num_PEs, set_rootPE, Set_PElist, Get_PElist use MOM_coms_infra, only : broadcast, field_chksum, MOM_infra_init, MOM_infra_end use MOM_coms_infra, only : sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms_infra, only : all_across_PEs, any_across_PEs use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING implicit none ; private public :: PE_here, root_PE, num_PEs, MOM_infra_init, MOM_infra_end public :: broadcast, sum_across_PEs, min_across_PEs, max_across_PEs, field_chksum +public :: all_across_PEs, any_across_PEs public :: set_PElist, Get_PElist, Set_rootPE public :: reproducing_sum, reproducing_sum_EFP, EFP_sum_across_PEs, EFP_list_sum_across_PEs public :: EFP_plus, EFP_minus, EFP_to_real, real_to_EFP, EFP_real_diff @@ -243,11 +245,11 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & integer(kind=8), dimension(ni) :: ints_sum integer(kind=8) :: prec_error - real :: rsum(1), rs + real :: rsum(1) logical :: repro, do_sum_across_PEs character(len=256) :: mesg type(EFP_type) :: EFP_val ! An extended fixed point version of the sum - integer :: i, j, n, is, ie, js, je + integer :: i, j, is, ie, js, je if (num_PEs() > max_count_prec) call MOM_error(FATAL, & "reproducing_sum: Too many processors are being used for the value of "//& diff --git a/src/framework/MOM_coupler_types.F90 b/src/framework/MOM_coupler_types.F90 index 73304f7fe8..f87b409694 100644 --- a/src/framework/MOM_coupler_types.F90 +++ b/src/framework/MOM_coupler_types.F90 @@ -19,8 +19,10 @@ module MOM_coupler_types public :: set_coupler_type_data, extract_coupler_type_data, coupler_type_redistribute_data public :: coupler_type_copy_data, coupler_type_increment_data, coupler_type_rescale_data public :: atmos_ocn_coupler_flux, coupler_type_data_override -public :: ind_flux, ind_alpha, ind_csurf public :: coupler_1d_bc_type, coupler_2d_bc_type, coupler_3d_bc_type +! These are encoding constant parameters that indicate whether a flux, solubility or +! surface ocean concentration are being set or accessed with an inquiry. +public :: ind_flux, ind_alpha, ind_csurf !> This is the interface to spawn one coupler_bc_type into another. interface coupler_type_spawn diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index eb24c994f8..9f6b57fe6c 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -41,7 +41,6 @@ module MOM_diag_mediator public set_axes_info, post_data, register_diag_field, time_type public post_product_u, post_product_sum_u, post_product_v, post_product_sum_v public set_masks_for_axes -public post_data_1d_k public safe_alloc_ptr, safe_alloc_alloc public enable_averaging, enable_averages, disable_averaging, query_averaging_enabled public diag_mediator_init, diag_mediator_end, set_diag_mediator_grid @@ -349,7 +348,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_null integer :: id_zl_native, id_zi_native - integer :: i, j, k, nz + integer :: i, j, nz real :: zlev(GV%ke), zinter(GV%ke+1) logical :: set_vert real, allocatable, dimension(:) :: IaxB,iax @@ -587,7 +586,7 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh - integer :: i, j, k, nz, dl + integer :: i, j, nz, dl real, dimension(:), pointer :: gridLonT_dsamp =>NULL() real, dimension(:), pointer :: gridLatT_dsamp =>NULL() real, dimension(:), pointer :: gridLonB_dsamp =>NULL() @@ -755,7 +754,7 @@ subroutine set_masks_for_axes(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj + integer :: c, nk, i, j, k type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience do c=1, diag_cs%num_diag_coords @@ -853,9 +852,8 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: c, nk, i, j, k, ii, jj - integer :: dl - type(axes_grp), pointer :: axes => NULL(), h_axes => NULL() ! Current axes, for convenience + integer :: c, dl + type(axes_grp), pointer :: axes => NULL() ! Current axes, for convenience !Each downsampled axis needs both downsampled and non-downsampled mask !The downsampled mask is needed for sending out the diagnostics output via diag_manager @@ -1378,7 +1376,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj - integer :: isv, iev, jsv, jev, i, j, chksum, isv_o,jsv_o + integer :: isv, iev, jsv, jev, i, j, isv_o,jsv_o real, dimension(:,:), allocatable, target :: locfield_dsamp real, dimension(:,:), allocatable, target :: locmask_dsamp integer :: dl @@ -1523,7 +1521,6 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) ! Local variables type(diag_type), pointer :: diag => null() - integer :: nz, i, j, k real, dimension(:,:,:), allocatable :: remapped_field logical :: staggered_in_x, staggered_in_y real, dimension(:,:,:), pointer :: h_diag => NULL() @@ -1648,7 +1645,6 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) logical :: is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o - integer :: chksum real, dimension(:,:,:), allocatable, target :: locfield_dsamp real, dimension(:,:,:), allocatable, target :: locmask_dsamp integer :: dl @@ -2235,7 +2231,7 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time ! Register the native diagnostic if (associated(axes_d2)) then - active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & + active = register_diag_field_expand_cmor(dm_id, new_module_name, field_name, axes_d2, & init_time, long_name=long_name, units=units, missing_value=MOM_missing_value, & range=range, mask_variant=mask_variant, standard_name=standard_name, & verbose=verbose, do_not_log=do_not_log, err_msg=err_msg, & @@ -2775,7 +2771,7 @@ end subroutine attach_cell_methods function register_scalar_field(module_name, field_name, init_time, diag_cs, & long_name, units, missing_value, range, standard_name, & do_not_log, err_msg, interp_method, cmor_field_name, & - cmor_long_name, cmor_units, cmor_standard_name) + cmor_long_name, cmor_units, cmor_standard_name, conversion) integer :: register_scalar_field !< An integer handle for a diagnostic array. character(len=*), intent(in) :: module_name !< Name of this module, usually "ocean_model" !! or "ice_shelf_model" @@ -2796,6 +2792,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file ! Local variables real :: MOM_missing_value @@ -2826,6 +2823,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call assert(associated(diag), 'register_scalar_field: diag allocation failed') diag%fms_diag_id = fms_id diag%debug_str = trim(module_name)//"-"//trim(field_name) + if (present(conversion)) diag%conversion_factor = conversion endif if (present(cmor_field_name)) then @@ -2856,6 +2854,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & call alloc_diag_with_id(dm_id, diag_cs, cmor_diag) cmor_diag%fms_diag_id = fms_id cmor_diag%debug_str = trim(module_name)//"-"//trim(cmor_field_name) + if (present(conversion)) cmor_diag%conversion_factor = conversion endif endif @@ -2912,7 +2911,7 @@ function register_static_field(module_name, field_name, axes, & real :: MOM_missing_value type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() - integer :: dm_id, fms_id, cmor_id + integer :: dm_id, fms_id character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name character(len=9) :: axis_name @@ -3729,7 +3728,7 @@ subroutine log_available_diag(used, module_name, field_name, cell_methods_string mesg = '"'//trim(field_name)//'" [Unused]' endif if (len(trim((comment)))>0) then - write(diag_CS%available_diag_doc_unit, '(a,x,"(",a,")")') trim(mesg),trim(comment) + write(diag_CS%available_diag_doc_unit, '(a,1x,"(",a,")")') trim(mesg),trim(comment) else write(diag_CS%available_diag_doc_unit, '(a)') trim(mesg) endif @@ -3751,7 +3750,7 @@ subroutine log_chksum_diag(docunit, description, chksum) character(len=*), intent(in) :: description !< Name of the diagnostic module integer, intent(in) :: chksum !< chksum of the diagnostic - write(docunit, '(a,x,i9.8)') description, chksum + write(docunit, '(a,1x,i9.8)') description, chksum flush(docunit) end subroutine log_chksum_diag @@ -3856,7 +3855,7 @@ end subroutine diag_restore_grids subroutine diag_grid_storage_end(grid_storage) type(diag_grid_storage), intent(inout) :: grid_storage !< Structure containing a snapshot of the target grids ! Local variables - integer :: m, nz + integer :: m ! Don't do anything else if there are no remapped coordinates if (grid_storage%num_diag_coords < 1) return @@ -3879,7 +3878,7 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) type(diag_ctrl), pointer :: diag_cs !< A pointer to a type with many variables !! used for diagnostics ! Local variables - integer :: i,j,k,ii,jj,dl + integer :: k, dl !print*,'original c extents ',G%isc,G%iec,G%jsc,G%jec !print*,'original c extents ',G%iscb,G%iecb,G%jscb,G%jecb @@ -4295,7 +4294,6 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 real :: ave, total_weight, weight - real :: epsilon = 1.0e-20 ! A negligibly small count of weights [nondim] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_len ! A negligibly small horizontal length [L ~> m] diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index f9e5a35a09..63e6bcba7a 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -189,16 +189,11 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) 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 + ! Local variables - integer :: nzi(4), nzl(4), k - character(len=200) :: inputdir, string, filename, int_varname, layer_varname character(len=40) :: mod = "MOM_diag_remap" ! This module's name. - character(len=8) :: units, expected_units - character(len=34) :: longname, string2 - - character(len=256) :: err_msg - logical :: ierr - + character(len=8) :: units + character(len=34) :: longname real, allocatable, dimension(:) :: interfaces, layers call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & @@ -363,7 +358,7 @@ subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_ real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing @@ -502,7 +497,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing @@ -582,7 +577,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] integer :: nz_src, nz_dest - integer :: i, j, k !< Grid index + integer :: i, j !< Grid index integer :: i1, j1 !< 1-based index integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices integer :: shift !< Symmetric offset for 1-based indexing diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 index 3d6e3e3f65..886f6dcd4d 100644 --- a/src/framework/MOM_diag_vkernels.F90 +++ b/src/framework/MOM_diag_vkernels.F90 @@ -98,12 +98,11 @@ subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells real, intent(in) :: missing_value !< Value to assign in vanished cells real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces + ! Local variables - real :: x_dest ! Relative position of target interface real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses - real :: uh_src_rem, uh_dest_rem, duh ! Incremental amounts of stuff + real :: uh_src_rem, duh ! Incremental amounts of stuff integer :: k_src, k_dest ! Index of cell in src and dest columns - integer :: iter logical :: src_ran_out, src_exists uh_dest(:) = missing_value @@ -294,7 +293,6 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces integer :: k real :: error - logical :: print_results ! Interpolate from src to dest call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) @@ -311,8 +309,8 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd if (error==0.) then write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) else - write(stdout,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' endif enddo endif @@ -333,7 +331,6 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells integer :: k real :: error - logical :: print_results ! Interpolate from src to dest call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) @@ -350,8 +347,8 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s if (error==0.) then write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) else - write(stdout,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' endif enddo endif diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index 24f77a0eb2..a68a725feb 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -389,7 +389,6 @@ subroutine doc_openBlock(doc, blockName, desc) character(len=*), optional, intent(in) :: desc !< A description of the parameter block being opened ! This subroutine handles documentation for opening a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring if (.not. (is_root_pe() .and. associated(doc))) return call open_doc_file(doc) @@ -413,7 +412,6 @@ subroutine doc_closeBlock(doc, blockName) character(len=*), intent(in) :: blockName !< The name of the parameter block being closed ! This subroutine handles documentation for closing a parameter block. character(len=mLen) :: mesg - character(len=doc%commentColumn) :: valstring integer :: i if (.not. (is_root_pe() .and. associated(doc))) return diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 0cdcc455fc..47ac43df06 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -10,14 +10,14 @@ module MOM_domains use MOM_domain_infra, only : create_MOM_domain, clone_MOM_domain, deallocate_MOM_domain use MOM_domain_infra, only : get_domain_extent, get_domain_components, same_domain use MOM_domain_infra, only : compute_block_extent, get_global_shape -use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges, global_field_sum +use MOM_domain_infra, only : pass_var, pass_vector, fill_symmetric_edges use MOM_domain_infra, only : pass_var_start, pass_var_complete use MOM_domain_infra, only : pass_vector_start, pass_vector_complete use MOM_domain_infra, only : create_group_pass, do_group_pass use MOM_domain_infra, only : start_group_pass, complete_group_pass use MOM_domain_infra, only : rescale_comp_data, global_field, redistribute_array, broadcast_domain use MOM_domain_infra, only : MOM_thread_affinity_set, set_MOM_thread_affinity -use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM +use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL @@ -54,9 +54,6 @@ module MOM_domains public :: CORNER, CENTER, NORTH_FACE, EAST_FACE !> These encoding constants indicate communication patterns. In practice they can be added. public :: To_East, To_West, To_North, To_South, To_All, Omit_Corners -! These are no longer used by MOM6 because the reproducing sum works so well, but they are -! still referenced by some of the non-GFDL couplers. -public :: global_field_sum, BITWISE_EXACT_SUM contains @@ -185,7 +182,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ "The number of OpenMP threads that MOM6 will use.", & !$ default = 1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & - !$ "If True, use hyper-threading.", default = .false., layoutParam=.true.) + !$ "If True, use hyper-threading.", default=.false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) !$ endif # endif @@ -220,11 +217,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "NIGLOBAL", n_global(1), & "The total number of thickness grid points in the x-direction in the physical "//& "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NIGLOBAL) + default=NIGLOBAL) call get_param(param_file, mdl, "NJGLOBAL", n_global(2), & "The total number of thickness grid points in the y-direction in the physical "//& "domain. With STATIC_MEMORY_ this is set in "//trim(inc_nm)//" at compile time.", & - static_value=NJGLOBAL) + default=NJGLOBAL) if (n_global(1) /= NIGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & "static mismatch for NIGLOBAL_ domain size. Header file does not match input namelist") if (n_global(2) /= NJGLOBAL) call MOM_error(FATAL,"MOM_domains_init: " // & @@ -256,11 +253,11 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, trim(nihalo_nm), n_halo(1), & "The number of halo points on each side in the x-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & - default=nihalo_dflt, static_value=nihalo_dflt) + default=nihalo_dflt) call get_param(param_file, mdl, trim(njhalo_nm), n_halo(2), & "The number of halo points on each side in the y-direction. How this is set "//& "varies with the calling component and static or dynamic memory configuration.", & - default=njhalo_dflt, static_value=njhalo_dflt) + default=njhalo_dflt) if (present(min_halo)) then n_halo(1) = max(n_halo(1), min_halo(1)) min_halo(1) = n_halo(1) @@ -343,7 +340,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Idiot check that fewer PEs than columns have been requested if (layout(1)*layout(2) > n_global(1)*n_global(2)) then - write(mesg,'(a,2(i5,x,a))') 'You requested to use',layout(1)*layout(2), & + write(mesg,'(a,2(i5,1x,a))') 'You requested to use', layout(1)*layout(2), & 'PEs but there are only', n_global(1)*n_global(2), 'columns in the model' call MOM_error(FATAL, mesg) endif diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 8264a903cf..bfc6f1b1a4 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -311,9 +311,6 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: turns !< Number of quarter turns - integer :: jsc, jec, jscB, jecB - integer :: qturn - ! Center point call rotate_array(G_in%geoLonT, turns, G%geoLonT) call rotate_array(G_in%geoLatT, turns, G%geoLatT) diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index 6051fed08b..d61e82b32c 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -3,7 +3,12 @@ module MOM_error_handler ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms_infra, only : num_PEs use MOM_error_infra, only : MOM_err, is_root_pe, stdlog, stdout, NOTE, WARNING, FATAL +use posix, only : getpid, getppid, handler_interface +use posix, only : signal, kill, SIGUSR1 +use posix, only : sigjmp_buf, siglongjmp +use posix, only : sleep implicit none ; private @@ -15,6 +20,7 @@ module MOM_error_handler public :: is_root_pe, stdlog, stdout !> Integer parameters encoding the severity of an error message public :: NOTE, WARNING, FATAL +public :: disable_fatal_errors, enable_fatal_errors integer :: verbosity = 6 !< Verbosity level: @@ -40,6 +46,19 @@ module MOM_error_handler integer :: callTreeIndentLevel = 0 !< The level of calling within the call tree +! Error handling + +logical :: ignore_fatal = .false. + !< If true, ignore FATAL errors and jump to a prior state. +integer, parameter :: err_signal = SIGUSR1 + !< Signal used to trigger the error handler +integer :: err_pid + !< Process ID for the error handler (either self or MPI launcher) +procedure(handler_interface), pointer :: prior_handler + !< The default signal handler used before signal() setup (usually SIG_DFT) +type(sigjmp_buf) :: prior_env + !< Buffer containing the program state to be recovered by longjmp + contains !> This provides a convenient interface for writing an informative comment, depending @@ -61,6 +80,47 @@ subroutine MOM_mesg(message, verb, all_print) end subroutine MOM_mesg +!> Enable error handling, replacing FATALs in MOM_error with err_handler. +subroutine disable_fatal_errors(env) + type(sigjmp_buf), intent(in) :: env + !> Process recovery state after FATAL errors + + integer :: sig + + ignore_fatal = .true. + + ! TODO: Only need to call this once; move to an init() function? + if (num_PEs() > 1) then + err_pid = getppid() + else + err_pid = getpid() + endif + + ! Store the program state + prior_env = env + + ! Setup the signal handler + ! NOTE: Passing parameters to signal() in GFortran causes a compiler error. + ! We avert this by copying err_signal to a variable. + sig = err_signal + ! TODO: Use sigaction() in place of signal() + prior_handler => signal(sig, err_handler) +end subroutine disable_fatal_errors + +!> Disable the error handler and abort on FATAL +subroutine enable_fatal_errors() + integer :: sig + procedure(handler_interface), pointer :: dummy + + ignore_fatal = .false. + err_pid = -1 ! NOTE: 0 might be safer, since it's unusable. + + ! Restore the original signal handler (usually SIG_DFT). + sig = err_signal + ! NOTE: As above, we copy the err_signal to accommodate GFortran. + dummy => signal(sig, prior_handler) +end subroutine enable_fatal_errors + !> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) @@ -71,6 +131,7 @@ subroutine MOM_error(level, message, all_print) ! This provides a convenient interface for writing an error message ! with run-time filter based on a verbosity. logical :: write_msg + integer :: rc write_msg = is_root_pe() if (present(all_print)) write_msg = write_msg .or. all_print @@ -81,6 +142,15 @@ subroutine MOM_error(level, message, all_print) case (WARNING) if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) case (FATAL) + if (ignore_fatal) then + print *, "(FATAL): " // message + rc = kill(err_pid, err_signal) + ! NOTE: MPI launchers require, in their words, "a few seconds" to + ! propagate the signal to the nodes, so we wait here to avoid + ! anomalous FATAL calls. + ! In practice, the signal will take control before sleep() completes. + rc = sleep(3) + endif if (verbosity>=0) call MOM_err(FATAL, message) case default call MOM_err(level, message) @@ -180,7 +250,13 @@ subroutine assert(logical_arg, msg) if (.not. logical_arg) then call MOM_error(FATAL, msg) endif - end subroutine assert +!> Restore the process state via longjmp after receiving a signal. +subroutine err_handler(sig) + integer, intent(in) :: sig + !< Signal passed to the handler (unused) + call siglongjmp(prior_env, 1) +end subroutine + end module MOM_error_handler diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 07e9138594..3a25981dc8 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -4,7 +4,8 @@ module MOM_file_parser ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : root_PE, broadcast -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_coms, only : any_across_PEs +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, assert use MOM_error_handler, only : is_root_pe, stdlog, stdout use MOM_time_manager, only : get_time, time_type, get_ticks_per_second use MOM_time_manager, only : set_date, get_date, real_to_time, operator(-), set_time @@ -15,13 +16,14 @@ module MOM_file_parser implicit none ; private +! These are hard-coded limits that are used in the following code. They should be set +! generously enough not to impose any significant limitations. integer, parameter, public :: MAX_PARAM_FILES = 5 !< Maximum number of parameter files. -integer, parameter :: INPUT_STR_LENGTH = 320 !< Maximum line length in parameter file. -integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. +integer, parameter :: INPUT_STR_LENGTH = 1024 !< Maximum line length in parameter file. Lines that + !! are combined by ending in '\' or '&' can exceed + !! this limit after merging. +integer, parameter :: FILENAME_LENGTH = 200 !< Maximum number of characters in file names. -! The all_PEs_read option should be eliminated with post-riga shared code. -logical :: all_PEs_read = .false. !< If true, all PEs read the input files - !! TODO: Eliminate this parameter !>@{ Default values for parameters logical, parameter :: report_unused_default = .true. @@ -31,22 +33,28 @@ module MOM_file_parser logical, parameter :: minimal_doc_default = .true. !>@} + +!> A simple type to allow lines in an array to be allocated with variable sizes. +type, private :: file_line_type ; private + character(len=:), allocatable :: line !< An allocatable line with content +end type file_line_type + !> The valid lines extracted from an input parameter file without comments type, private :: file_data_type ; private integer :: num_lines = 0 !< The number of lines in this type - character(len=INPUT_STR_LENGTH), pointer, dimension(:) :: line => NULL() !< The line content - logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read + type(file_line_type), allocatable, dimension(:) :: fln !< Lines with the input content. + logical, pointer, dimension(:) :: line_used => NULL() !< If true, the line has been read end type file_data_type !> A link in the list of variables that have already had override warnings issued -type :: link_parameter ; private +type, private :: link_parameter ; private type(link_parameter), pointer :: next => NULL() !< Facilitates linked list character(len=80) :: name !< Parameter name logical :: hasIssuedOverrideWarning = .false. !< Has a default value end type link_parameter !> Specify the active parameter block -type :: parameter_block ; private +type, private :: parameter_block ; private character(len=240) :: name = '' !< The active parameter block name end type parameter_block @@ -68,6 +76,9 @@ module MOM_file_parser logical :: log_to_stdout = log_to_stdout_default !< If true, all log !! messages are also sent to stdout. logical :: log_open = .false. !< True if the log file has been opened. + integer :: max_line_len = 4 !< The maximum number of characters in the lines + !! in any of the files in this param_file_type after + !! any continued lines have been combined. integer :: stdout !< The unit number from stdout(). integer :: stdlog !< The unit number from stdlog(). character(len=240) :: doc_file !< A file where all run-time parameters, their @@ -125,7 +136,7 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! the documentation files. The default is effectively './'. ! Local variables - logical :: file_exists, unit_in_use, Netcdf_file, may_check + logical :: file_exists, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path type(parameter_block), pointer :: block => NULL() @@ -140,30 +151,29 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) ! Check that this file has not already been opened if (CS%nfiles > 0) then + reopened_file = .false. inquire(file=trim(filename), number=iounit) if (iounit /= -1) then do i = 1, CS%nfiles if (CS%iounit(i) == iounit) then - if (trim(CS%filename(1)) /= trim(filename)) then - call MOM_error(FATAL, & + call assert(trim(CS%filename(1)) == trim(filename), & "open_param_file: internal inconsistency! "//trim(filename)// & " is registered as open but has the wrong unit number!") - else - call MOM_error(WARNING, & + call MOM_error(WARNING, & "open_param_file: file "//trim(filename)// & " has already been opened. This should NOT happen!"// & " Did you specify the same file twice in a namelist?") - return - endif ! filenames + reopened_file = .true. endif ! unit numbers enddo ! i endif + if (any_across_PEs(reopened_file)) return endif ! Check that the file exists to readstdlog inquire(file=trim(filename), exist=file_exists) if (.not.file_exists) call MOM_error(FATAL, & - "open_param_file: Input file "// trim(filename)//" does not exist.") + "open_param_file: Input file '"// trim(filename)//"' does not exist.") Netcdf_file = .false. if (strlen > 3) then @@ -173,19 +183,10 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (Netcdf_file) & call MOM_error(FATAL,"open_param_file: NetCDF files are not yet supported.") - if (all_PEs_read .or. is_root_pe()) then - ! Find an unused unit number. - do iounit=10,512 - INQUIRE(iounit,OPENED=unit_in_use) ; if (.not.unit_in_use) exit - enddo - if (iounit >= 512) call MOM_error(FATAL, & - "open_param_file: No unused file unit could be found.") - - ! Open the parameter file. - open(iounit, file=trim(filename), access='SEQUENTIAL', & + if (is_root_pe()) then + open(newunit=iounit, file=trim(filename), access='SEQUENTIAL', & form='FORMATTED', action='READ', position='REWIND', iostat=ios) - if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening "// & - trim(filename)) + if (ios /= 0) call MOM_error(FATAL, "open_param_file: Error opening '"//trim(filename)//"'.") else iounit = 1 endif @@ -200,10 +201,11 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) if (associated(CS%blockName)) deallocate(CS%blockName) allocate(block) ; block%name = '' ; CS%blockName => block - call MOM_mesg("open_param_file: "// trim(filename)// & - " has been opened successfully.", 5) + call MOM_mesg("open_param_file: "// trim(filename)//" has been opened successfully.", 5) call populate_param_data(iounit, filename, CS%param_data(i)) + ! Increment the maximum line length, but always report values in blocks of 4 characters. + CS%max_line_len = max(CS%max_line_len, 4 + 4*(max_input_line_length(CS, i) - 1) / 4) call read_param(CS,"SEND_LOG_TO_STDOUT",CS%log_to_stdout) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) @@ -257,17 +259,19 @@ subroutine close_param_file(CS, quiet_close, component) if (present(quiet_close)) then ; if (quiet_close) then do i = 1, CS%nfiles - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) + if (is_root_pe()) close(CS%iounit(i)) call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & " has been closed successfully.", 5) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo CS%log_open = .false. call doc_end(CS%doc) + deallocate(CS%doc) return endif ; endif @@ -320,18 +324,18 @@ subroutine close_param_file(CS, quiet_close, component) num_unused = num_unused + 1 if (CS%report_unused) & call MOM_error(WARNING, "Unused line in "//trim(CS%filename(i))// & - " : "//trim(CS%param_data(i)%line(n))) + " : "//trim(CS%param_data(i)%fln(n)%line)) endif enddo endif - if (all_PEs_read .or. is_root_pe()) close(CS%iounit(i)) - call MOM_mesg("close_param_file: "// trim(CS%filename(i))// & - " has been closed successfully.", 5) + if (is_root_pe()) close(CS%iounit(i)) + call MOM_mesg("close_param_file: "// trim(CS%filename(i))//" has been closed successfully.", 5) CS%iounit(i) = -1 CS%filename(i) = '' CS%NetCDF_file(i) = .false. - deallocate (CS%param_data(i)%line) + do n=1,CS%param_data(i)%num_lines ; deallocate(CS%param_data(i)%fln(n)%line) ; enddo + deallocate (CS%param_data(i)%fln) deallocate (CS%param_data(i)%line_used) enddo deallocate(CS%blockName) @@ -341,7 +345,7 @@ subroutine close_param_file(CS, quiet_close, component) CS%log_open = .false. call doc_end(CS%doc) - + deallocate(CS%doc) end subroutine close_param_file !> Read the contents of a parameter input file, and store the contents in a @@ -354,29 +358,32 @@ subroutine populate_param_data(iounit, filename, param_data) ! Local variables character(len=INPUT_STR_LENGTH) :: line - integer :: num_lines + character(len=1), allocatable, dimension(:) :: char_buf + integer, allocatable, dimension(:) :: line_len ! The trimmed length of each processed input line + integer :: n, num_lines, total_chars, ch, rsc, llen, int_buf(2) logical :: inMultiLineComment ! Find the number of keyword lines in a parameter file - ! Allocate the space to hold the lines in param_data%line - ! Populate param_data%line with the keyword lines from parameter file - - if (iounit <= 0) return - - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) ! count the number of valid entries in the parameter file num_lines = 0 + total_chars = 0 inMultiLineComment = .false. do while(.true.) - read(iounit, '(a)', end=8, err=9) line + read(iounit, '(a)', end=8) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. else - if (lastNonCommentNonBlank(line)>0) num_lines = num_lines + 1 + if (lastNonCommentNonBlank(line)>0) then + line = removeComments(line) + line = simplifyWhiteSpace(line(:len_trim(line))) + num_lines = num_lines + 1 + total_chars = total_chars + len_trim(line) + endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif enddo ! while (.true.) @@ -386,60 +393,76 @@ subroutine populate_param_data(iounit, filename, param_data) call MOM_error(FATAL, 'MOM_file_parser : A C-style multi-line comment '// & '(/* ... */) was not closed before the end of '//trim(filename)) - ! allocate space to hold contents of the parameter file - param_data%num_lines = num_lines + + int_buf(1) = num_lines + int_buf(2) = total_chars endif ! (is_root_pe()) ! Broadcast the number of valid entries in parameter file - if (.not. all_PEs_read) then - call broadcast(param_data%num_lines, root_pe()) - endif + call broadcast(int_buf, 2, root_pe()) + num_lines = int_buf(1) + total_chars = int_buf(2) ! Set up the space for storing the actual lines. - num_lines = param_data%num_lines - allocate (param_data%line(num_lines)) - allocate (param_data%line_used(num_lines)) - param_data%line(:) = ' ' - param_data%line_used(:) = .false. + param_data%num_lines = num_lines + allocate (line_len(num_lines), source=0) + allocate (char_buf(total_chars), source=" ") ! Read the actual lines. - if (all_PEs_read .or. is_root_pe()) then + if (is_root_pe()) then ! rewind the parameter file rewind(iounit) - ! Populate param_data%line + ! Populate param_data%fln%line num_lines = 0 + rsc = 0 do while(.true.) - read(iounit, '(a)', end=18, err=9) line + read(iounit, '(a)', end=18) line line = replaceTabs(line) if (inMultiLineComment) then if (closeMultiLineComment(line)) inMultiLineComment=.false. else if (lastNonCommentNonBlank(line)>0) then line = removeComments(line) + if ((len_trim(line) > 1000) .and. is_root_PE()) then + call MOM_error(WARNING, "MOM_file_parser: Consider using continuation to split up "//& + "the excessivley long parameter input line "//trim(line)) + endif line = simplifyWhiteSpace(line(:len_trim(line))) num_lines = num_lines + 1 - param_data%line(num_lines) = line + llen = len_trim(line) + line_len(num_lines) = llen + do ch=1,llen ; char_buf(rsc+ch)(1:1) = line(ch:ch) ; enddo + rsc = rsc + llen endif if (openMultiLineComment(line)) inMultiLineComment=.true. endif enddo ! while (.true.) 18 continue ! get here when read() reaches EOF - if (num_lines /= param_data%num_lines) & - call MOM_error(FATAL, 'MOM_file_parser : Found different number of '// & - 'valid lines on second reading of '//trim(filename)) + call assert(num_lines == param_data%num_lines, & + 'MOM_file_parser: Found different number of valid lines on second ' & + // 'reading of '//trim(filename)) endif ! (is_root_pe()) - ! Broadcast the populated array param_data%line - if (.not. all_PEs_read) then - call broadcast(param_data%line, INPUT_STR_LENGTH, root_pe()) - endif + ! Broadcast the populated arrays line_len and char_buf + call broadcast(line_len, num_lines, root_pe()) + call broadcast(char_buf(1:total_chars), 1, root_pe()) - return + ! Allocate space to hold contents of the parameter file, including the lines in param_data%fln + allocate(param_data%fln(num_lines)) + allocate(param_data%line_used(num_lines)) + param_data%line_used(:) = .false. + ! Populate param_data%fln%line with the keyword lines from parameter file + rsc = 0 + do n=1,num_lines + line(1:INPUT_STR_LENGTH) = " " + do ch=1,line_len(n) ; line(ch:ch) = char_buf(rsc+ch)(1:1) ; enddo + param_data%fln(n)%line = trim(line) + rsc = rsc + line_len(n) + enddo -9 call MOM_error(FATAL, "MOM_file_parser : "//& - "Error while reading file "//trim(filename)) + deallocate(char_buf) ; deallocate(line_len) end subroutine populate_param_data @@ -589,7 +612,7 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -621,7 +644,7 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -657,7 +680,7 @@ subroutine read_param_real(CS, varname, value, fail_if_missing, scale) !! by before it is returned. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) @@ -693,8 +716,8 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing, scale) !! by before it is returned. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) - logical :: found, defined + character(len=CS%max_line_len) :: value_string(1) + logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found .and. defined .and. (LEN_TRIM(value_string(1)) > 0)) then @@ -728,15 +751,14 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string) if (found) then value = trim(strip_quotes(value_string(1))) elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_char @@ -752,7 +774,7 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1), loc_string + character(len=CS%max_line_len) :: value_string(1), loc_string logical :: found, defined integer :: i, i_out @@ -773,8 +795,7 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) endif do i=i_out,SIZE(value) ; value(i) = " " ; enddo elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_char_array @@ -790,15 +811,14 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) !! if this variable is not found in the parameter file ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) logical :: found, defined call get_variable_line(CS, varname, found, defined, value_string, paramIsLogical=.true.) if (found) then value = defined elseif (present(fail_if_missing)) then ; if (fail_if_missing) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') endif ; endif end subroutine read_param_logical @@ -817,7 +837,7 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f !! later be logged in the same format. ! Local variables - character(len=INPUT_STR_LENGTH) :: value_string(1) + character(len=CS%max_line_len) :: value_string(1) character(len=240) :: err_msg logical :: found, defined real :: real_time, time_unit @@ -859,11 +879,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f else if (present(fail_if_missing)) then ; if (fail_if_missing) then if (.not.found) then - call MOM_error(FATAL,'Unable to find variable '//trim(varname)// & - ' in any input files.') + call MOM_error(FATAL, 'Unable to find variable '//trim(varname)//' in any input files.') else - call MOM_error(FATAL,'Variable '//trim(varname)// & - ' found but not set in input files.') + call MOM_error(FATAL, 'Variable '//trim(varname)//' found but not set in input files.') endif endif ; endif endif @@ -875,8 +893,8 @@ end subroutine read_param_time !> This function removes single and double quotes from a character string function strip_quotes(val_str) - character(len=*) :: val_str !< The character string to work on - character(len=INPUT_STR_LENGTH) :: strip_quotes + character(len=*), intent(in) :: val_str !< The character string to work on + character(len=len(val_str)) :: strip_quotes ! Local variables integer :: i strip_quotes = val_str @@ -894,7 +912,68 @@ function strip_quotes(val_str) enddo end function strip_quotes -!> This subtoutine extracts the contents of lines in the param_file_type that refer to +!> This function returns the maximum number of characters in any input lines after they +!! have been combined by any line continuation. +function max_input_line_length(CS, pf_num) result(max_len) + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + integer, optional, intent(in) :: pf_num !< If present, only work on a single file in the + !! param_file_type, or return 0 if this exceeds the + !! number of files in the param_file_type. + integer :: max_len !< The maximum number of characters in any input lines after they + !! have been combined by any line continuation. + + ! Local variables + character(len=FILENAME_LENGTH) :: filename + character :: last_char + integer :: ipf, ipf_s, ipf_e + integer :: last, line_len, count, contBufSize + logical :: continuedLine + + max_len = 0 + ipf_s = 1 ; ipf_e = CS%nfiles + if (present(pf_num)) then + if (pf_num > CS%nfiles) return + ipf_s = pf_num ; ipf_e = pf_num + endif + + paramfile_loop: do ipf = ipf_s, ipf_e + filename = CS%filename(ipf) + contBufSize = 0 + continuedLine = .false. + + ! Scan through each line of the file + do count = 1, CS%param_data(ipf)%num_lines + ! line = CS%param_data(ipf)%fln(count)%line + last = len_trim(CS%param_data(ipf)%fln(count)%line) + last_char = " " + if (last > 0) last_char = CS%param_data(ipf)%fln(count)%line(last:last) + ! Check if line ends in continuation character (either & or \) + ! Note achar(92) is a backslash + if (last_char == achar(92) .or. last_char == "&") then + contBufSize = contBufSize + last - 1 + continuedLine = .true. + if (count==CS%param_data(ipf)%num_lines .and. is_root_pe()) & + call MOM_error(FATAL, "MOM_file_parser : the last line of the file ends in a"// & + " continuation character but there are no more lines to read. "// & + " Line: '"//trim(CS%param_data(ipf)%fln(count)%line(:last))//"'"// & + " in file "//trim(filename)//".") + cycle ! cycle inorder to append the next line of the file + elseif (continuedLine) then + ! If we reached this point then this is the end of line continuation + line_len = contBufSize + last + contBufSize = 0 + continuedLine = .false. + else ! This is a simple line with no continuation. + line_len = last + endif + max_len = max(max_len, line_len) + enddo ! CS%param_data(ipf)%num_lines + enddo paramfile_loop + +end function max_input_line_length + +!> This subroutine extracts the contents of lines in the param_file_type that refer to !! a named parameter. The value_string that is returned must be interepreted in a way !! that depends on the type of this variable. subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) @@ -908,10 +987,11 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL !! that can be simply defined without parsing a value_string. ! Local variables - character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine - character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName - character(len=FILENAME_LENGTH) :: filename - integer :: is, id, isd, isu, ise, iso, verbose, ipf + character(len=CS%max_line_len) :: val_str, lname, origLine + character(len=CS%max_line_len) :: line, continuationBuffer + character(len=240) :: blockName + character(len=FILENAME_LENGTH) :: filename + integer :: is, id, isd, isu, ise, iso, ipf integer :: last, last1, ival, oval, max_vals, count, contBufSize character(len=52) :: set logical :: found_override, found_equals @@ -920,10 +1000,10 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL logical :: variableKindIsLogical, valueIsSame logical :: inWrongBlock, fullPathParameter logical, parameter :: requireNamedClose = .false. + integer, parameter :: verbose = 1 set = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" - continuationBuffer = repeat(" ",INPUT_STR_LENGTH) + continuationBuffer = repeat(" ", CS%max_line_len) contBufSize = 0 - verbose = 1 variableKindIsLogical=.false. if (present(paramIsLogical)) variableKindIsLogical = paramIsLogical @@ -943,7 +1023,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! Scan through each line of the file do count = 1, CS%param_data(ipf)%num_lines - line = CS%param_data(ipf)%line(count) + line = CS%param_data(ipf)%fln(count)%line last = len_trim(line) last1 = max(1,last) @@ -964,7 +1044,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! If we reached this point then this is the end of line continuation continuationBuffer(contBufSize+1:contBufSize+len_trim(line))=line(:last) line = continuationBuffer - continuationBuffer=repeat(" ",INPUT_STR_LENGTH) ! Clear for next use + continuationBuffer=repeat(" ",CS%max_line_len) ! Clear for next use contBufSize = 0 continuedLine = .false. last = len_trim(line) @@ -986,25 +1066,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL line = trim(adjustl(line(iso+10:last))); last = len_trim(line) endif - ! Check for start of fortran namelist, ie. '&namelist' - if (index(line(:last),'&')==1) then - iso=index(line(:last),' ') - if (iso>0) then ! possibly simething else on this line - blockName = pushBlockLevel(blockName,line(2:iso-1)) - line=trim(adjustl(line(iso:last))) - last=len_trim(line) - if (last==0) cycle ! nothing else on this line - else ! just the namelist on this line - if (len_trim(blockName)>0) then - blockName = trim(blockName) // '%' //trim(line(2:last)) - else - blockName = trim(line(2:last)) - endif - call flag_line_as_read(CS%param_data(ipf)%line_used,count) - cycle - endif - endif - ! Newer form of parameter block, block%, %block or block%param or iso=index(line(:last),'%') fullPathParameter = .false. @@ -1042,14 +1103,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL if (trim(CS%blockName%name)/=trim(blockName)) inWrongBlock = .true. ! Not in the required block endif - ! Check for termination of a fortran namelist (with a '/') - if (line(last:last)=='/') then - if (len_trim(blockName)==0 .and. is_root_pe()) call MOM_error(FATAL, & - 'get_variable_line: An extra namelist/block end was encountered. Line="'// & - trim(line(:last))//'"' ) - blockName = popBlockLevel(blockName) - last = last - 1 ! Ignore the termination character from here on - endif if (inWrongBlock .and. .not. fullPathParameter) then if (index(" "//line(:last+1), " "//trim(varname)//" ")>0) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & @@ -1069,29 +1122,28 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL if (index(line(:last), "#undef ")==1) found_undef = .true. ! Check for missing, mutually exclusive or incomplete keywords - if (is_root_pe()) then - if (.not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : the parameter name '"// & - trim(varname)//"' was found without define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_define .and. found_undef) call MOM_error(FATAL, & - "MOM_file_parser : Both 'undef' and 'define' occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_equals .and. (found_define .or. found_undef)) & - call MOM_error(FATAL, & - "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") - if (found_override .and. .not. (found_define .or. found_undef .or. found_equals)) & - call MOM_error(FATAL, "MOM_file_parser : override was found "// & - " without a define or undef."// & - " Line: '"//trim(line(:last))//"'"//& - " in file "//trim(filename)//".") + if (.not. (found_define .or. found_undef .or. found_equals)) then + if (found_override) then + call MOM_error(FATAL, "MOM_file_parser : override was found " // & + " without a define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + else + call MOM_error(FATAL, "MOM_file_parser : the parameter name '" // & + trim(varname) // "' was found without define or undef." // & + " Line: '" // trim(line(:last)) // "'" // & + " in file " // trim(filename) // ".") + endif endif + if (found_equals .and. (found_define .or. found_undef)) & + call MOM_error(FATAL, & + "MOM_file_parser : Both 'a=b' and 'undef/define' syntax occur."// & + " Line: '"//trim(line(:last))//"'"//& + " in file "//trim(filename)//".") + ! Interpret the line and collect values, if any + ! NOTE: At least one of these must be true if (found_define) then ! Move starting pointer to first letter of defined name. is = isd + 5 + scan(line(isd+6:last), set) @@ -1131,10 +1183,6 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL defined_in_line = .true. endif found = .true. - else - call MOM_error(FATAL, "MOM_file_parser (non-root PE?): the parameter name '"// & - trim(varname)//"' was found without an assignment, define or undef."// & - " Line: '"//trim(line(:last))//"'"//" in file "//trim(filename)//".") endif ! This line has now been used. @@ -1201,6 +1249,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ival = ival + 1 value_string(ival) = trim(val_str) defined = defined_in_line + if (verbose > 1 .and. is_root_pe()) & call MOM_error(WARNING,"MOM_file_parser : "//trim(varname)// & " set. Line: '"//trim(line(:last))//"'"//& @@ -1219,8 +1268,8 @@ end subroutine get_variable_line !> Record that a line has been used to set a parameter subroutine flag_line_as_read(line_used, count) - logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read - integer, intent(in) :: count !< The parameter on this line number has been read + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read line_used(count) = .true. end subroutine flag_line_as_read @@ -1344,7 +1393,7 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. - character(len=1320) :: mesg + character(len=CS%max_line_len+120) :: mesg character(len=240) :: myunits write(mesg, '(" ",a," ",a,": ",A)') trim(modulename), trim(varname), trim(left_ints(value)) @@ -1486,16 +1535,16 @@ subroutine log_param_char(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. - character(len=1024) :: mesg, myunits + character(len=:), allocatable :: mesg + character(len=240) :: myunits - write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(value) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(value) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits=" "; if (present(units)) write(myunits(1:1024),'(A)') trim(units) + myunits=" "; if (present(units)) write(myunits(1:240),'(A)') trim(units) if (present(desc)) & call doc_param(CS%doc, varname, desc, myunits, value, default, & layoutParam=layoutParam, debuggingParam=debuggingParam, like_default=like_default) @@ -1531,7 +1580,7 @@ subroutine log_param_time(CS, modulename, varname, value, desc, units, & logical :: use_timeunit, date_format character(len=240) :: mesg, myunits character(len=80) :: date_string, default_string - integer :: days, secs, ticks, ticks_per_sec + integer :: days, secs, ticks use_timeunit = .false. date_format = .false. ; if (present(log_date)) date_format = log_date @@ -1628,7 +1677,7 @@ end function convert_date_to_string !! and logs it in documentation files. subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1639,9 +1688,6 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1660,7 +1706,6 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_int(CS, varname, value, fail_if_missing) endif @@ -1675,7 +1720,7 @@ end subroutine get_param_int !! and logs them in documentation files. subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1686,9 +1731,6 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter integer, optional, intent(in) :: default !< The default value of the parameter - integer, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1706,8 +1748,7 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_int_array(CS, varname, value, fail_if_missing) endif @@ -1722,7 +1763,7 @@ end subroutine get_param_int_array !! and logs it in documentation files. subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, debuggingParam, scale, unscaled) + debuggingParam, scale, unscaled) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1733,9 +1774,6 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1756,7 +1794,6 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_real(CS, varname, value, fail_if_missing) endif @@ -1774,7 +1811,7 @@ end subroutine get_param_real !! and logs them in documentation files. subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, debuggingParam, & - static_value, scale, unscaled) + scale, unscaled) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1785,9 +1822,6 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter real, optional, intent(in) :: default !< The default value of the parameter - real, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1807,8 +1841,7 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_real_array(CS, varname, value, fail_if_missing) endif @@ -1826,7 +1859,7 @@ end subroutine get_param_real_array !! and logs it in documentation files. subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1837,9 +1870,6 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1858,7 +1888,6 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_char(CS, varname, value, fail_if_missing) endif @@ -1872,7 +1901,7 @@ end subroutine get_param_char !> This subroutine reads the values of an array of character string model parameters !! from a parameter file and logs them in documentation files. subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & - default, fail_if_missing, do_not_read, do_not_log, static_value) + default, fail_if_missing, do_not_read, do_not_log) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1883,9 +1912,6 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter character(len=*), optional, intent(in) :: default !< The default value of the parameter - character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1896,19 +1922,18 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & ! Local variables logical :: do_read, do_log integer :: i, len_tot, len_val - character(len=1024) :: cat_val + character(len=:), allocatable :: cat_val do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log if (do_read) then - if (present(default)) then ; value(:) = default ; endif - if (present(static_value)) then ; value(:) = static_value ; endif + if (present(default)) value(:) = default call read_param_char_array(CS, varname, value, fail_if_missing) endif if (do_log) then - cat_val = trim(value(1)); len_tot = len_trim(value(1)) + cat_val = trim(value(1)) ; len_tot = len_trim(value(1)) do i=2,size(value) len_val = len_trim(value(i)) if ((len_val > 0) .and. (len_tot + len_val + 2 < 240)) then @@ -1926,7 +1951,7 @@ end subroutine get_param_char_array !! and logs it in documentation files. subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - static_value, layoutParam, debuggingParam) + layoutParam, debuggingParam) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1937,9 +1962,6 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter logical, optional, intent(in) :: default !< The default value of the parameter - logical, optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -1958,7 +1980,6 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_logical(CS, varname, value, fail_if_missing) endif @@ -1973,7 +1994,7 @@ end subroutine get_param_logical !! and logs it in documentation files. subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & - timeunit, static_value, layoutParam, debuggingParam, & + timeunit, layoutParam, debuggingParam, & log_as_date) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters @@ -1985,9 +2006,6 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & !! present, this parameter is not written to a doc file character(len=*), optional, intent(in) :: units !< The units of this parameter type(time_type), optional, intent(in) :: default !< The default value of the parameter - type(time_type), optional, intent(in) :: static_value !< If this parameter is static, it takes - !! this value, which can be compared for consistency with - !! what is in the parameter file. logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs !! if this variable is not found in the parameter file logical, optional, intent(in) :: do_not_read !< If present and true, do not read a @@ -2003,7 +2021,7 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date !! format. The default is false. - logical :: do_read, do_log, date_format, log_date + logical :: do_read, do_log, log_date do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read do_log = .true. ; if (present(do_not_log)) do_log = .not.do_not_log @@ -2011,7 +2029,6 @@ subroutine get_param_time(CS, modulename, varname, value, desc, units, & if (do_read) then if (present(default)) value = default - if (present(static_value)) value = static_value call read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format=log_date) endif diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index de511688a9..ebc59cd288 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -12,8 +12,9 @@ module MOM_horizontal_regridding use MOM_error_handler, only : MOM_get_verbosity use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_interpolate, only : time_interp_external, horiz_interp_init -use MOM_interpolate, only : build_horiz_interp_weights, run_horiz_interp, horiz_interp_type +use MOM_interpolate, only : time_interp_external +use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights +use MOM_interp_infra, only : horiz_interp_type, horizontal_interp_init use MOM_interp_infra, only : axistype, get_external_field_info, get_axis_data use MOM_time_manager, only : time_type use MOM_io, only : axis_info, get_axis_info, get_var_axes_info, MOM_read_data @@ -34,21 +35,25 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, is, ie, js, je, k, mesg) - real, dimension(:,:), intent(in) :: array !< input array (ND) - real, intent(in) :: missing !< missing value (ND) - integer :: is !< Start index in i - integer :: ie !< End index in i - integer :: js !< Start index in j - integer :: je !< End index in j - integer :: k !< Level to calculate statistics for - character(len=*) :: mesg !< Label to use in message +subroutine myStats(array, missing, is, ie, js, je, k, mesg, scale) + real, dimension(:,:), intent(in) :: array !< input array [A] + real, intent(in) :: missing !< missing value [A] + integer, intent(in) :: is !< Start index in i + integer, intent(in) :: ie !< End index in i + integer, intent(in) :: js !< Start index in j + integer, intent(in) :: je !< End index in j + integer, intent(in) :: k !< Level to calculate statistics for + character(len=*), intent(in) :: mesg !< Label to use in message + real, optional, intent(in) :: scale !< A scaling factor for output. ! Local variables - real :: minA, maxA + real :: minA, maxA ! Minimum and maximum vvalues in the array [A] + real :: scl ! A factor for undoing any scaling of the array statistics for output. integer :: i,j logical :: found character(len=120) :: lMesg - minA = 9.E24 ; maxA = -9.E24 ; found = .false. + + scl = 1.0 ; if (present(scale)) scl = scale + minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. do j=js,je ; do i=is,ie if (array(i,j) /= array(i,j)) stop 'Nan!' @@ -66,8 +71,8 @@ subroutine myStats(array, missing, is, ie, js, je, k, mesg) call min_across_PEs(minA) call max_across_PEs(maxA) if (is_root_pe()) then - write(lMesg(1:120),'(2(a,es12.4),a,i3,x,a)') & - 'init_from_Z: min=',minA,' max=',maxA,' Level=',k,trim(mesg) + write(lMesg(1:120),'(2(a,es12.4),a,i3,1x,a)') & + 'init_from_Z: min=',minA*scl,' max=',maxA*scl,' Level=',k,trim(mesg) call MOM_mesg(lMesg,2) endif @@ -76,50 +81,47 @@ end subroutine myStats !> Use ICE-9 algorithm to populate points (fill=1) with valid data (good=1). If no information !! is available, use a previous guess (prev). Optionally (smooth) blend the filled points to !! achieve a more desirable result. -subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, debug, answers_2018) - use MOM_coms, only : sum_across_PEs - +subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, answers_2018) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: aout !< The array with missing values to fill + intent(inout) :: aout !< The array with missing values to fill [A] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: good !< Valid data mask for incoming array - !! (1==good data; 0==missing data). + !! (1==good data; 0==missing data) [nondim]. real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: fill !< Same shape array of points which need - !! filling (1==fill;0==dont fill) + !! filling (1==fill;0==dont fill) [nondim] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: prev !< First guess where isolated holes exist. - logical, optional, intent(in) :: smooth !< If present and true, apply a number of - !! Laplacian iterations to the interpolated data + intent(in) :: prev !< First guess where isolated holes exist [A] + real, intent(in) :: acrit !< A minimal value for deltas between iterations that + !! determines when the smoothing has converged [A]. integer, optional, intent(in) :: num_pass !< The maximum number of iterations - real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian (ND) - real, optional, intent(in) :: crit !< A minimal value for deltas between iterations. + real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian [nondim] logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. - real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in - real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing - real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled - real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration - real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration - - real :: east, west, north, south ! Valid neighboring values or 0 for invalid values - real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values - real :: ngood ! The number of valid values in neighboring points - logical :: do_smooth ! Indicates whether to do smoothing of the array - real :: nfill ! The remaining number of points to fill - real :: nfill_prev ! The previous value of nfill + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [A] + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [A] + real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] + + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [A] + real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values [nondim] + real :: ngood ! The number of valid values in neighboring points [nondim] + real :: nfill ! The remaining number of points to fill [nondim] + real :: nfill_prev ! The previous value of nfill [nondim] character(len=256) :: mesg ! The text of an error message integer :: i, j, k integer, parameter :: num_pass_default = 10000 - real, parameter :: relc_default = 0.25, crit_default = 1.e-3 + real, parameter :: relc_default = 0.25 ! The default relaxation coefficient [nondim] - integer :: npass + integer :: npass ! The maximum number of passes of the Laplacian smoother integer :: is, ie, js, je - real :: relax_coeff, acrit, ares + real :: relax_coeff ! The grid-scale Laplacian relaxation coefficient per timestep [nondim] + real :: ares ! The maximum magnitude change in aout [A] logical :: debug_it, ans_2018 debug_it=.false. @@ -133,12 +135,6 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, relax_coeff = relc_default if (PRESENT(relc)) relax_coeff = relc - acrit = crit_default - if (PRESENT(crit)) acrit = crit - - do_smooth=.false. - if (PRESENT(smooth)) do_smooth=smooth - ans_2018 = .true. ; if (PRESENT(answers_2018)) ans_2018 = answers_2018 fill_pts(:,:) = fill(:,:) @@ -192,7 +188,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, nfill = sum(fill_pts(is:ie,js:je)) call sum_across_PEs(nfill) - if (nfill == nfill_prev .and. PRESENT(prev)) then + if (nfill == nfill_prev) then do j=js,je ; do i=is,ie ; if (fill_pts(i,j) == 1.0) then aout(i,j) = prev(i,j) fill_pts(i,j) = 0.0 @@ -213,7 +209,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, enddo ! while block for remaining points to fill. ! Do Laplacian smoothing for the points that have been filled in. - if (do_smooth) then ; do k=1,npass + do k=1,npass call pass_var(aout,G%Domain) do j=js,je ; do i=is,ie if (fill(i,j) == 1) then @@ -239,7 +235,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, enddo ; enddo call max_across_PEs(ares) if (ares <= acrit) exit - enddo ; endif + enddo do j=js,je ; do i=is,ie if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then @@ -248,61 +244,75 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, smooth, num_pass, relc, crit, call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") endif - enddo ; enddo + enddo ; enddo end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record -subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, & - mask_z, z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, m_to_Z, answers_2018, ongrid) +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & + homogenize, m_to_Z, answers_2018, ongrid, tr_iter_tol) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. character(len=*), intent(in) :: varnam !< Name of tracer in file. - real, intent(in) :: conversion !< Conversion factor for tracer. + real, intent(in) :: conversion !< Conversion factor for tracer [CU conc-1 ~> 1] integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and input-file vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels. [CU ~> conc] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and input-file vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! with conversion to avoid accidentally having valid + !! values match missing values [CU ~> conc] logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. logical, optional, intent(in) :: ongrid !< If true, then data are assumed to have been interpolated !! to the model horizontal grid. In this case, only !! extrapolation is performed by this routine + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating [CU ~> conc] ! Local variables real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its - !! native horizontal grid. - real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. - real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid. - - real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp + !! native horizontal grid, with units that change + !! as the input data is interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes integer :: i, j, k - integer, dimension(4) :: start, count, dims, dim_id - real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file - real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole - real :: max_lat, min_lat, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. - real :: add_offset, scale_factor + integer, dimension(4) :: start, count + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: pole ! The sum of tracer values at the pole [conc] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [conc] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] + real :: add_offset, scale_factor ! File-specific conversion factors. logical :: found_attr logical :: add_np logical :: is_ongrid @@ -310,21 +320,25 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, type(horiz_interp_type) :: Interp type(axis_info), dimension(4) :: axes_info ! Axis information used for regridding integer :: is, ie, js, je ! compute domain indices - integer :: isc, iec, jsc, jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read - character(len=12) :: dim_name(4) logical :: debug=.false. - real :: npoints, varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. - real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above - real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 + real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [CU ~> conc] + real :: npoints ! The number of points in an average [nondim] + real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -335,8 +349,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, is_ongrid = .false. if (present(ongrid)) is_ongrid = ongrid - if (allocated(tr_z)) deallocate(tr_z) - if (allocated(mask_z)) deallocate(mask_z) + dtr_iter_stop = 1.0e-3*conversion + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / conversion PI_180 = atan(1.0)/45. @@ -357,7 +373,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call get_axis_info(axes_info(3),ax_size=kd) allocate(lon_in(id), lat_in(jd), z_in(kd), z_edges_in(kd+1)) - allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) call get_axis_info(axes_info(1),ax_data=lon_in) call get_axis_info(axes_info(2),ax_data=lat_in) @@ -367,12 +384,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (present(m_to_Z)) then ; do k=1,kd ; z_in(k) = m_to_Z * z_in(k) ; enddo ; endif - ! extrapolate the input data to the north pole using the northern-most latitude add_np = .false. jdp = jd if (.not. is_ongrid) then max_lat = maxval(lat_in) if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -386,11 +403,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, ! construct level cell boundaries as the mid-point between adjacent centers ! Set the I/O attributes - call read_attribute(trim(filename), "_FillValue", missing_value, & + call read_attribute(trim(filename), "_FillValue", missing_val_in, & varname=trim(varnam), found=found_attr) if (.not. found_attr) call MOM_error(FATAL, & "error finding missing value for " // trim(varnam) // & " in file " // trim(filename) // " in hinterp_extrap") + missing_value = conversion * missing_val_in call read_attribute(trim(filename), "scale_factor", scale_factor, & varname=trim(varnam), found=found_attr) @@ -410,7 +428,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, allocate(tr_in(is:ie,js:je), source=0.0) allocate(mask_in(is:ie,js:je), source=0.0) else - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -426,21 +444,22 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call max_across_PEs(max_depth) if (z_edges_in(kd+1) < max_depth) z_edges_in(kd+1) = max_depth - roundoff = 3.0*EPSILON(missing_value) + roundoff = 3.0*EPSILON(missing_val_in) - ! loop through each data level and interpolate to model grid. - ! after interpolating, fill in points which will be needed - ! to define the layers + ! Loop through each data level and interpolate to model grid. + ! After interpolating, fill in points which will be needed to define the layers. do k=1,kd write(laynum,'(I8)') k ; laynum = adjustl(laynum) - mask_in = 0.0 + mask_in(:,:) = 0.0 + tr_out(:,:) = 0.0 + if (is_ongrid) then start(1) = is+G%HI%idg_offset ; start(2) = js+G%HI%jdg_offset ; start(3) = k count(1) = ie-is+1 ; count(2) = je-js+1; count(3) = 1; start(4) = 1; count(4) = 1 call MOM_read_data(trim(filename), trim(varnam), tr_in, G%Domain, timelevel=1) do j=js,je do i=is,ie - if (abs(tr_in(i,j)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion else @@ -448,7 +467,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, endif enddo enddo - else + + tr_out(is:ie,js:je) = tr_in(is:ie,js:je) + + else ! .not.is_ongrid + start(:) = 1 ; start(3) = k count(:) = 1 ; count(1) = id ; count(2) = jd call read_variable(trim(filename), trim(varnam), tr_in, start=start, nread=count) @@ -456,15 +479,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) npole = npole + 1.0 endif enddo if (npole > 0) then - pole=pole/npole + pole = pole / npole else - pole=missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -475,80 +498,65 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call broadcast(tr_inp, id*jdp, blocking=.true.) - do j=1,jdp - do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then - mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion - else - tr_inp(i,j) = missing_value - endif - enddo - enddo - - endif + do j=1,jdp ; do i=1,id + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then + mask_in(i,j) = 1.0 + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + else + tr_inp(i,j) = missing_value + endif + enddo ; enddo -! call fms routine horiz_interp to interpolate input level data to model horizontal grid - if (.not. is_ongrid) then + ! call fms routine horiz_interp to interpolate input level data to model horizontal grid if (k == 1) then call build_horiz_interp_weights(Interp, x_in, y_in, lon_out(is:ie,js:je), lat_out(is:ie,js:je), & interp_method='bilinear', src_modulo=.true.) endif if (debug) then - call myStats(tr_inp,missing_value, is, ie, js, je, k,'Tracer from file') + call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) endif - endif - tr_out(:,:) = 0.0 - if (is_ongrid) then - tr_out(is:ie,js:je)=tr_in(is:ie,js:je) - else call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) - endif + endif ! End of .not.is_ongrid - mask_out=1.0 - do j=js,je - do i=is,ie - if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. - enddo - enddo + mask_out(:,:) = 1.0 + do j=js,je ; do i=is,ie + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j) = 0. + enddo ; enddo - fill = 0.0; good = 0.0 + fill(:,:) = 0.0 ; good(:,:) = 0.0 nPoints = 0 ; varAvg = 0. - do j=js,je - do i=is,ie - if (mask_out(i,j) < 1.0) then - tr_out(i,j)=missing_value - else - good(i,j)=1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) - endif - if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & - (mask_out(i,j) < 1.0)) & - fill(i,j)=1.0 - enddo - enddo - call pass_var(fill,G%Domain) - call pass_var(good,G%Domain) + do j=js,je ; do i=is,ie + if (mask_out(i,j) < 1.0) then + tr_out(i,j) = missing_value + else + good(i,j) = 1.0 + nPoints = nPoints + 1 + varAvg = varAvg + tr_out(i,j) + endif + if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & + (mask_out(i,j) < 1.0)) & + fill(i,j) = 1.0 + enddo ; enddo + call pass_var(fill, G%Domain) + call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out,missing_value, is,ie,js,je,k,'variable from horiz_interp()') + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions - if (PRESENT(homogenize)) then - if (homogenize) then - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg/real(nPoints) - endif - tr_out(:,:) = varAvg + if (PRESENT(homogenize)) then ; if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. + call sum_across_PEs(nPoints) + call sum_across_PEs(varAvg) + if (nPoints>0) then + varAvg = varAvg / real(nPoints) endif - endif + tr_out(:,:) = varAvg + endif ; endif ! tr_out contains input z-space data on the model grid with missing values ! now fill in missing values using "ICE-nine" algorithm. @@ -557,9 +565,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, & + answers_2018=answers_2018) if (debug) then - call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') + call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -568,7 +577,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) endif enddo ! kd @@ -579,75 +588,92 @@ end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & - z_in, z_edges_in, missing_value, reentrant_x, & - tripolar_n, homogenize, spongeOngrid, m_to_Z, answers_2018) + z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & + homogenize, spongeOngrid, m_to_Z, answers_2018, tr_iter_tol) integer, intent(in) :: fms_id !< A unique id used by the FMS time interpolator type(time_type), intent(in) :: Time !< A FMS time type real, intent(in) :: conversion !< Conversion factor for tracer. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z - !< pointer to allocatable tracer array on local - !! model grid and native vertical levels. + !< Allocatable tracer array on the horizontal + !! model grid and input-file vertical levels. [CU ~> conc] real, allocatable, dimension(:,:,:), intent(out) :: mask_z - !< pointer to allocatable tracer mask array on - !! local model grid and native vertical levels. + !< Allocatable tracer mask array on the horizontal + !! model grid and input-file vertical levels [nondim] real, allocatable, dimension(:), intent(out) :: z_in - !< Cell grid values for input data. + !< Cell grid values for input data [Z ~> m] real, allocatable, dimension(:), intent(out) :: z_edges_in - !< Cell grid edge values for input data. - real, intent(out) :: missing_value !< The missing value in the returned array. + !< Cell grid edge values for input data [Z ~> m] + real, intent(out) :: missing_value !< The missing value in the returned array, scaled + !! with conversion to avoid accidentally having valid + !! values match missing values [CU ~> conc] logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units - !! of depth. If missing, G%bathyT must be in m. + !! of depth [Z m-1 ~> 1]. If missing, G%bathyT must be in m. logical, optional, intent(in) :: answers_2018 !< If true, use expressions that give the same !! answers as the code did in late 2018. Otherwise !! add parentheses for rotational symmetry. + real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations + !! between smoothing iterations that determines when to + !! stop iterating [CU ~> conc] ! Local variables real, dimension(:,:), allocatable :: tr_in !< A 2-d array for holding input data on its - !! native horizontal grid. - real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles. + !! native horizontal grid, with units that change + !! as the input data is interpreted [conc] then [CU ~> conc] + real, dimension(:,:), allocatable :: tr_inp !< Native horizontal grid data extended to the poles + !! with units that change as the input data is + !! interpreted [conc] then [CU ~> conc] real, dimension(:,:,:), allocatable :: data_in !< A buffer for storing the full 3-d time-interpolated array - !! on the original grid - real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid. - - real :: PI_180 - integer :: rcode, ncid, varid, ndims, id, jd, kd, jdp - integer :: i,j,k - integer, dimension(4) :: start, count, dims, dim_id - real, dimension(:,:), allocatable :: x_in, y_in - real, dimension(:), allocatable :: lon_in, lat_in ! The longitude and latitude in the input file - real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole - real :: max_lat, min_lat, pole, max_depth, npole - real :: roundoff ! The magnitude of roundoff, usually ~2e-16. + !! on the original grid [conc] + real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] + + real :: PI_180 ! A conversion factor from degrees to radians + integer :: id, jd, kd, jdp ! Input dataset data sizes + integer :: i, j, k + real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] + real, dimension(:,:), allocatable :: y_in ! Input file latitudes [radians] + real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] + real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] + real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] + real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: pole ! The sum of tracer values at the pole [conc] + real :: max_depth ! The maximum depth of the ocean [Z ~> m] + real :: npole ! The number of points contributing to the pole value [nondim] + real :: missing_val_in ! The missing value in the input field [conc] + real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np character(len=8) :: laynum type(horiz_interp_type) :: Interp type(axistype), dimension(4) :: axes_data integer :: is, ie, js, je ! compute domain indices - integer :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read integer, dimension(4) :: fld_sz - character(len=12) :: dim_name(4) logical :: debug=.false. - logical :: spongeDataOngrid + logical :: is_ongrid logical :: ans_2018 - real :: npoints, varAvg - real, dimension(SZI_(G),SZJ_(G)) :: lon_out, lat_out ! The longitude and latitude of points on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: tr_out, mask_out ! The tracer and mask on the model grid - real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1. - real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above - real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 - real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 + real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing + ! iterations that determines when to stop iterating [CU ~> conc] + real :: npoints ! The number of points in an average [nondim] + real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] + real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] integer :: turns integer :: verbosity @@ -659,6 +685,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) + dtr_iter_stop = 1.0e-3*conversion + if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol + + I_scale = 1.0 / conversion + PI_180 = atan(1.0)/45. ans_2018 = .true.;if (present(answers_2018)) ans_2018 = answers_2018 @@ -668,15 +699,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_begin(id_clock_read) - call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_value) + call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_val_in) + missing_value = conversion*missing_val_in verbosity = MOM_get_verbosity() id = fld_sz(1) ; jd = fld_sz(2) ; kd = fld_sz(3) - spongeDataOngrid = .false. - if (PRESENT(spongeOngrid)) spongeDataOngrid = spongeOngrid - if (.not. spongeDataOngrid) then + is_ongrid = .false. + if (PRESENT(spongeOngrid)) is_ongrid = spongeOngrid + if (.not. is_ongrid) then allocate(lon_in(id), lat_in(jd)) call get_axis_data(axes_data(1), lon_in) call get_axis_data(axes_data(2), lat_in) @@ -684,7 +716,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t allocate(z_in(kd), z_edges_in(kd+1)) - allocate(tr_z(isd:ied,jsd:jed,kd), mask_z(isd:ied,jsd:jed,kd)) + allocate(tr_z(isd:ied,jsd:jed,kd), source=0.0) + allocate(mask_z(isd:ied,jsd:jed,kd), source=0.0) call get_axis_data(axes_data(3), z_in) @@ -692,11 +725,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_end(id_clock_read) - if (.not. spongeDataOngrid) then - ! Extrapolate the input data to the north pole using the northerm-most latitude. + if (.not. is_ongrid) then max_lat = maxval(lat_in) add_np = .false. if (max_lat < 90.0) then + ! Extrapolate the input data to the north pole using the northern-most latitude. add_np = .true. jdp = jd+1 allocate(lat_inp(jdp)) @@ -708,7 +741,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else jdp = jd endif - call horiz_interp_init() + call horizontal_interp_init() lon_in = lon_in*PI_180 lat_in = lat_in*PI_180 allocate(x_in(id,jdp), y_in(id,jdp)) @@ -722,23 +755,23 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t else allocate(data_in(isd:ied,jsd:jed,kd)) endif - ! construct level cell boundaries as the mid-point between adjacent centers + + ! Construct level cell boundaries as the mid-point between adjacent centers. z_edges_in(1) = 0.0 - do k=2,kd - z_edges_in(k) = 0.5*(z_in(k-1)+z_in(k)) + do K=2,kd + z_edges_in(K) = 0.5*(z_in(k-1)+z_in(k)) enddo z_edges_in(kd+1) = 2.0*z_in(kd) - z_in(kd-1) - - max_depth = maxval(G%bathyT) + G%Z_ref + max_depth = maxval(G%bathyT(:,:)) + G%Z_ref call max_across_PEs(max_depth) - if (z_edges_in(kd+1)5), turns=turns) ! Loop through each data level and interpolate to model grid. @@ -750,15 +783,15 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (add_np) then pole = 0.0 ; npole = 0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_val_in) > abs(roundoff*missing_val_in)) then pole = pole + tr_in(i,jd) - npole = npole+1.0 + npole = npole + 1.0 endif enddo if (npole > 0) then pole = pole / npole else - pole = missing_value + pole = missing_val_in endif tr_inp(:,1:jd) = tr_in(:,:) tr_inp(:,jdp) = pole @@ -772,7 +805,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t mask_in(:,:) = 0.0 do j=1,jdp ; do i=1,id - if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then + if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 tr_inp(i,j) = tr_inp(i,j) * conversion else @@ -787,7 +820,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t endif if (debug) then - call myStats(tr_in, missing_value, 1, id, 1, jd, k, 'Tracer from file') + call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) endif tr_out(:,:) = 0.0 @@ -818,15 +851,16 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()') + call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. call sum_across_PEs(nPoints) call sum_across_PEs(varAvg) if (nPoints>0) then - varAvg = varAvg/real(nPoints) + varAvg = varAvg / real(nPoints) endif tr_out(:,:) = varAvg endif ; endif @@ -838,35 +872,36 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t good2(:,:) = good(:,:) fill2(:,:) = fill(:,:) - call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, smooth=.true., answers_2018=answers_2018) + call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, & + answers_2018=answers_2018) ! if (debug) then -! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI) +! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) +! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) ! endif -! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()') - - tr_z(:,:,k) = tr_outf(:,:)*G%mask2dT(:,:) + tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) mask_z(:,:,k) = good2(:,:) + fill2(:,:) tr_prev(:,:) = tr_z(:,:,k) if (debug) then - call hchksum(tr_prev,'field after fill ',G%HI) + call hchksum(tr_prev, 'field after fill ', G%HI, scale=I_scale) endif enddo ! kd else - call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) - do k=1,kd - do j=js,je - do i=is,ie - tr_z(i,j,k)=data_in(i,j,k) - if (.not. ans_2018) mask_z(i,j,k) = 1. - if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. - enddo + call time_interp_external(fms_id, Time, data_in, verbose=(verbosity>5), turns=turns) + do k=1,kd + do j=js,je + do i=is,ie + tr_z(i,j,k) = data_in(i,j,k) * conversion + if (.not. ans_2018) mask_z(i,j,k) = 1. + if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. enddo enddo + enddo endif + end subroutine horiz_interp_and_extrap_tracer_fms_id !> Create a 2d-mesh of grid coordinates from 1-d arrays. diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index 4a931d0bf3..8f20bf73fe 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -6,15 +6,15 @@ module MOM_interpolate use MOM_array_transform, only : allocate_rotated_array, rotate_array use MOM_error_handler, only : MOM_error, FATAL use MOM_interp_infra, only : time_interp_extern, init_external_field=>init_extern_field -use MOM_interp_infra, only : time_interp_external_init, get_external_field_info -use MOM_interp_infra, only : horiz_interp_type, horiz_interp_init +use MOM_interp_infra, only : time_interp_external_init=>time_interp_extern_init +use MOM_interp_infra, only : horiz_interp_type, get_external_field_info use MOM_interp_infra, only : run_horiz_interp, build_horiz_interp_weights use MOM_time_manager, only : time_type implicit none ; private public :: time_interp_external, init_external_field, time_interp_external_init, get_external_field_info -public :: horiz_interp_type, horiz_interp_init, run_horiz_interp, build_horiz_interp_weights +public :: horiz_interp_type, run_horiz_interp, build_horiz_interp_weights !> Read a field based on model time, and rotate to the model domain. interface time_interp_external diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 8928d2e56b..e8df89b268 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -21,7 +21,6 @@ module MOM_io use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix use MOM_io_infra, only : write_field, write_metadata, write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end -use MOM_io_infra, only : stdout_if_root use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -587,6 +586,11 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim end subroutine reopen_file +!> Return the index of sdtout if called from the root PE, or 0 for other PEs. +integer function stdout_if_root() + stdout_if_root = 0 + if (is_root_PE()) stdout_if_root = stdout +end function stdout_if_root !> This function determines how many time levels a variable has in a file. function num_timelevels(filename, varname, min_dims) result(n_time) @@ -599,7 +603,7 @@ function num_timelevels(filename, varname, min_dims) result(n_time) integer :: n_time !< number of time levels varname has in filename character(len=256) :: msg - integer :: ncid, status, varid, ndims + integer :: ndims integer :: sizes(8) n_time = -1 @@ -922,7 +926,6 @@ subroutine read_variable_2d(filename, varname, var, start, nread, ncid_in) integer, allocatable :: field_start(:), field_nread(:) integer :: i, rc character(len=*), parameter :: hdr = "read_variable_2d: " - character(len=128) :: msg ! Validate shape of start and nread if (present(start)) then @@ -2104,7 +2107,6 @@ subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, ti real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled real :: scale_fac ! A scaling factor to use before writing the array integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale @@ -2139,7 +2141,6 @@ subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, ti real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled real :: scale_fac ! A scaling factor to use before writing the array integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale @@ -2174,7 +2175,6 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units real :: scale_fac ! A scaling factor to use before writing the array integer :: qturns ! The number of quarter turns through which to rotate field - integer :: is, ie, js, je ! The extent of the computational domain qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) scale_fac = 1.0 ; if (present(scale)) scale_fac = scale @@ -2303,7 +2303,7 @@ function ensembler(name, ens_no_in) result(en_nm) character(10) :: ens_num_char character(3) :: code_str integer :: ens_no - integer :: n, is, ie + integer :: n, is en_nm = trim(name) if (index(name,"%") == 0) return @@ -2404,7 +2404,6 @@ subroutine get_var_axes_info(filename, fieldname, axes_info) integer :: ncid, varid, ndims integer :: id, jd, kd integer, dimension(4) :: dims, dim_id - real :: missing_value character(len=128) :: dim_name(4) integer, dimension(1) :: start, count !! cartesian axis data diff --git a/src/framework/MOM_random.F90 b/src/framework/MOM_random.F90 index bef78a433a..fbdc916346 100644 --- a/src/framework/MOM_random.F90 +++ b/src/framework/MOM_random.F90 @@ -7,6 +7,7 @@ module MOM_random use MOM_time_manager, only : time_type, set_date, get_date use iso_fortran_env, only : stdout=>output_unit, stderr=>error_unit +use iso_fortran_env, only : int32 implicit none ; private @@ -20,11 +21,13 @@ module MOM_random public :: random_unit_tests ! Private period parameters for the Mersenne Twister -integer, parameter :: blockSize = 624, & !< Size of the state vector - M = 397, & !< Pivot element in state vector - MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) - UMASK = -2147483648_8, & !< most significant w-r bits (0x80000000UL) - LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) +integer, parameter :: & + blockSize = 624, & !< Size of the state vector + M = 397, & !< Pivot element in state vector + MATRIX_A = -1727483681, & !< constant vector a (0x9908b0dfUL) + UMASK = ibset(0, 31), & !< most significant w-r bits (0x80000000UL) + LMASK = 2147483647 !< least significant r bits (0x7fffffffUL) + ! Private tempering parameters for the Mersenne Twister integer, parameter :: TMASKB= -1658038656, & !< (0x9d2c5680UL) TMASKC= -272236544 !< (0xefc60000UL) @@ -189,7 +192,7 @@ integer function seed_from_index(HI, i, j) integer, intent(in) :: i !< i-index (of h-cell) integer, intent(in) :: j !< j-index (of h-cell) ! Local variables - integer :: ig, jg, ni, nj, ij + integer :: ig, jg, ni, nj ni = HI%niglobal nj = HI%njglobal diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 1328fd676c..2687b6f8c6 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -59,6 +59,10 @@ module MOM_restart !! read from the restart file. logical :: initialized !< .true. if this field has been read from the restart file. character(len=32) :: var_name !< A name by which a variable may be queried. + real :: conv = 1.0 !< A factor by which a restart field should be multiplied before it + !! is written to a restart file, usually to convert it to MKS or + !! other standard units. When read, the restart field is multiplied + !! by the Adcroft reciprocal of this factor. end type field_restart !> A structure to store information about restart fields that are no longer used @@ -146,13 +150,15 @@ subroutine register_restart_field_as_obsolete(field_name, replacement_name, CS) end subroutine register_restart_field_as_obsolete !> Register a 3-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -166,6 +172,8 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr3d") @@ -179,13 +187,15 @@ subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr3d !> Register a 4-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -199,6 +209,8 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr4d") @@ -212,13 +224,15 @@ subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr4d !> Register a 2-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -232,6 +246,8 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr2d") @@ -245,12 +261,14 @@ subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -264,6 +282,8 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr1d") @@ -277,12 +297,14 @@ subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS) end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure -subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) +subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS, conversion) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -296,6 +318,8 @@ subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS) CS%restart_field(CS%novars)%vars = var_desc CS%restart_field(CS%novars)%mand_var = mandatory CS%restart_field(CS%novars)%initialized = .false. + CS%restart_field(CS%novars)%conv = 1.0 + if (present(conversion)) CS%restart_field(CS%novars)%conv = conversion call query_vardesc(CS%restart_field(CS%novars)%vars, & name=CS%restart_field(CS%novars)%var_name, & caller="register_restart_field_ptr0d") @@ -311,66 +335,72 @@ end subroutine register_restart_field_ptr0d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr2d !> Register a pair of rotationally equivalent 3d restart fields subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr3d !> Register a pair of rotationally equivalent 2d restart fields subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & - mandatory, CS) + mandatory, CS, conversion) real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer - type(vardesc), intent(in) :: a_desc !< First field descriptor - type(vardesc), intent(in) :: b_desc !< Second field descriptor - logical, intent(in) :: mandatory !< If true, abort if field is missing - type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + type(vardesc), intent(in) :: a_desc !< First field descriptor + type(vardesc), intent(in) :: b_desc !< Second field descriptor + logical, intent(in) :: mandatory !< If true, abort if field is missing + type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. call lock_check(CS, a_desc) if (modulo(CS%turns, 2) /= 0) then - call register_restart_field(b_ptr, a_desc, mandatory, CS) - call register_restart_field(a_ptr, b_desc, mandatory, CS) + call register_restart_field(b_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(a_ptr, b_desc, mandatory, CS, conversion) else - call register_restart_field(a_ptr, a_desc, mandatory, CS) - call register_restart_field(b_ptr, b_desc, mandatory, CS) + call register_restart_field(a_ptr, a_desc, mandatory, CS, conversion) + call register_restart_field(b_ptr, b_desc, mandatory, CS, conversion) endif end subroutine register_restart_pair_ptr4d @@ -378,7 +408,7 @@ end subroutine register_restart_pair_ptr4d ! The following provide alternate interfaces to register restarts. !> Register a 4-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -388,6 +418,8 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -403,12 +435,12 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -418,6 +450,8 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -433,12 +467,12 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_3d !> Register a 2-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written @@ -448,6 +482,8 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, '1' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -466,12 +502,12 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & z_grid=zgrid, t_grid=t_grid) - call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr2d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_2d !> Register a 1-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file @@ -480,6 +516,8 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, '1' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -498,12 +536,12 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid=hgrid, & z_grid=z_grid, t_grid=t_grid) - call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr1d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_1d !> Register a 0-d field for restarts, providing the metadata as individual arguments -subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, & +subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, conversion, & t_grid) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written character(len=*), intent(in) :: name !< variable name to be used in the restart file @@ -512,6 +550,8 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units + real, optional, intent(in) :: conversion !< A factor to multiply a restart field by + !! before it is written, 1 by default. character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd @@ -525,7 +565,7 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units vd = var_desc(name, units=units, longname=longname, hor_grid='1', & z_grid='1', t_grid=t_grid) - call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS) + call register_restart_field_ptr0d(f_ptr, vd, mandatory, CS, conversion) end subroutine register_restart_field_0d @@ -909,7 +949,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. - character(len=64) :: var_name ! A variable's name. + real :: conv ! Shorthand for the conversion factor real :: restart_time character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. @@ -1025,16 +1065,17 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) endif do m=start_var,next_var-1 + conv = CS%restart_field(m)%conv if (associated(CS%var_ptr3d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:), turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL), turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:), turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr1d(m)%p) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr1d(m)%p(:)) elseif (associated(CS%var_ptr0d(m)%p)) then - check_val(m-start_var+1,1) = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + check_val(m-start_var+1,1) = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) endif enddo @@ -1048,18 +1089,20 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,next_var-1 if (associated(CS%var_ptr3d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr3d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr3d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr2d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr2d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr2d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr4d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, & - CS%var_ptr4d(m)%p, restart_time, turns=-turns) + call MOM_write_field(IO_handle, fields(m-start_var+1), G%Domain, CS%var_ptr4d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv, turns=-turns) elseif (associated(CS%var_ptr1d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr1d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv) elseif (associated(CS%var_ptr0d(m)%p)) then - call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, restart_time) + call MOM_write_field(IO_handle, fields(m-start_var+1), CS%var_ptr0d(m)%p, & + restart_time, scale=CS%restart_field(m)%conv) endif enddo @@ -1085,17 +1128,14 @@ subroutine restore_state(filename, directory, day, G, CS) type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct ! Local variables - character(len=200) :: filepath ! The path (dir/file) to the file being opened. - character(len=80) :: fname ! The name of the current file. - character(len=8) :: suffix ! A suffix (like "_2") that is added to any - ! additional restart files. + real :: scale ! A scaling factor for reading a field + real :: conv ! The output conversion factor for writing a field character(len=512) :: mesg ! A message for warnings. character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others ! explicitly in filename) that are open. integer :: i, n, m, missing_fields - integer :: isL, ieL, jsL, jeL, is0, js0 - integer :: sizes(7) + integer :: isL, ieL, jsL, jeL integer :: nvar, ntime, pos type(file_type) :: IO_handles(CS%max_fields) ! The I/O units of all open files. @@ -1198,6 +1238,8 @@ subroutine restore_state(filename, directory, day, G, CS) case ('1') ; pos = 0 case default ; pos = 0 end select + conv = CS%restart_field(m)%conv + if (conv == 0.0) then ; scale = 1.0 ; else ; scale = 1.0 / conv ; endif call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do i=1, nvar @@ -1214,42 +1256,42 @@ subroutine restore_state(filename, directory, day, G, CS) if (associated(CS%var_ptr1d(m)%p)) then ! Read a 1d array, which should be invariant to domain decomposition. call MOM_read_data(unit_path(n), varname, CS%var_ptr1d(m)%p, & - timelevel=1, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr1d(m)%p) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr1d(m)%p(:)) elseif (associated(CS%var_ptr0d(m)%p)) then ! Read a scalar... call MOM_read_data(unit_path(n), varname, CS%var_ptr0d(m)%p, & - timelevel=1, MOM_Domain=G%Domain) - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) + timelevel=1, scale=scale, MOM_Domain=G%Domain) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr0d(m)%p, pelist=(/PE_here()/)) elseif (associated(CS%var_ptr2d(m)%p)) then ! Read a 2d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr2d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 2-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr2d(m)%p,no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr2d(m)%p(isL:ieL,jsL:jeL)) elseif (associated(CS%var_ptr3d(m)%p)) then ! Read a 3d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 3-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr3d(m)%p, no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr3d(m)%p(isL:ieL,jsL:jeL,:)) elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - G%Domain, timelevel=1, position=pos) + G%Domain, timelevel=1, position=pos, scale=scale) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 4-d arrays without domain decomposition.") ! call read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, no_domain=.true., timelevel=1) endif - if (is_there_a_checksum) checksum_data = chksum(CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) + if (is_there_a_checksum) checksum_data = chksum(conv*CS%var_ptr4d(m)%p(isL:ieL,jsL:jeL,:,:)) else call MOM_error(FATAL, "MOM_restart restore_state: No pointers set for "//trim(varname)) endif diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index ddc1b41290..65aa864f4e 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -17,7 +17,6 @@ module MOM_string_functions public extract_real public remove_spaces public slasher -public append_substring contains @@ -248,7 +247,6 @@ integer function extract_integer(string, separators, n, missing_value) integer, intent(in) :: n !< Number of word to extract integer, optional, intent(in) :: missing_value !< Value to assign if word is missing ! Local variables - integer :: ns, i, b, e, nw character(len=20) :: word word = extract_word(string, separators, n) @@ -272,7 +270,6 @@ real function extract_real(string, separators, n, missing_value) integer, intent(in) :: n !< Number of word to extract real, optional, intent(in) :: missing_value !< Value to assign if word is missing ! Local variables - integer :: ns, i, b, e, nw character(len=20) :: word word = extract_word(string, separators, n) @@ -419,34 +416,6 @@ function slasher(dir) endif end function slasher -!> append a string (substring) to another string (string_in) and return the -!! concatenated string (string_out) -function append_substring(string_in, substring) result(string_out) - character(len=*), intent(in) :: string_in !< input string - character(len=*), intent(in) :: substring !< string to append string_in - ! local - character(len=1024) :: string_out - character(len=1024) :: string_joined - integer :: string_in_length - integer :: substring_length - - string_out = '' - string_joined = '' - string_in_length = 0 - substring_length = 0 - - string_in_length = len_trim(string_in) - substring_length = len_trim(substring) - - if (string_in_length > 0) then - if (substring_length > 0) then - string_joined = trim(string_in)//trim(substring) - string_out(1:len_trim(string_joined)) = trim(string_joined) - endif - endif - -end function append_substring - !> \namespace mom_string_functions !! !! By Alistair Adcroft and Robert Hallberg, last updated Sept. 2013. diff --git a/src/framework/MOM_unique_scales.F90 b/src/framework/MOM_unique_scales.F90 new file mode 100644 index 0000000000..730d11adb0 --- /dev/null +++ b/src/framework/MOM_unique_scales.F90 @@ -0,0 +1,354 @@ +!> This module provides tools that can be used to check the uniqueness of the dimensional +!! scaling factors used by the MOM6 ocean model or other models +module MOM_unique_scales + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, assert, MOM_get_verbosity + +implicit none ; private + +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + +public check_scaling_uniqueness, scales_to_powers + +contains + +!> This subroutine does a checks whether the provided dimensional scaling factors give a unique +!! overall scaling for each of the combinations of units in description, and suggests a better +!! combination if it is not unique. However, this subroutine does nothing if the verbosity level +!! for this run is below 3. +subroutine check_scaling_uniqueness(component, descs, weights, key, scales, max_powers) + character(len=*), intent(in) :: component !< The name of the component (e.g., MOM6) to use in messages + character(len=*), intent(in) :: descs(:) !< The descriptions for each combination of units + integer, intent(in) :: weights(:) !< A list of the weights for each described combination + character(len=*), intent(in) :: key(:) !< The key for the unit scaling + integer, intent(in) :: scales(:) !< The powers of 2 that give the scaling for each unit in key + integer, optional, intent(in) :: max_powers !< The maximum range of powers of 2 to search for + !! suggestions of better scaling factors, or 0 to avoid + !! suggesting improved factors. + + ! Local variables + integer, dimension(size(key)) :: next_scales, prev_scales, better_scales + character(len=512) :: mesg + character(len=64) :: msg_frag + integer, dimension(size(key), size(weights)) :: list + integer :: verbosity + logical :: same_key + integer :: orig_cost, test_cost, better_cost, prev_cost ! Various squared-weight mismatch costs. + integer :: better_dp ! The absolute change in powers with the better estimate. + integer :: ndims, ns, m, n, i, p, itt, max_itt, max_pow + + call assert((size(scales) == size(key)), "check_scaling_factors: Mismatched scales and key sizes.") + call assert((size(descs) == size(weights)), "check_scaling_factors: Mismatched descs and weights.") + + verbosity = MOM_get_verbosity() + ! Skip the rest of this routine if it would not write anything out. + if (verbosity < 3) return + + ndims = size(key) + ns = size(weights) + max_pow = 0 ; if (present(max_powers)) max_pow = max_powers + + list(:,:) = 0 + do n=1,ns + call encode_dim_powers(descs(n), key, list(:,n)) + enddo + + if (verbosity >= 7) then + write(mesg, '(I8)') ns + call MOM_mesg(trim(component)//": Extracted "//trim(adjustl(mesg))//" unit combinations from the list.") + mesg = "Dim Key: [" + do i=1,ndims ; mesg = trim(mesg)//" "//trim(key(i)) ; enddo + mesg = trim(mesg)//"]:" + call MOM_mesg(mesg) + do n=1,ns + call MOM_mesg(trim(component)//": Extracted ["//trim(int_array_msg(list(:,n)))//"] from "//trim(descs(n))) + enddo + + do n=1,ns ; do m=1,n-1 + same_key = .true. + do i=1,ndims ; if (list(i,n) /= list(i,m)) same_key = .false. ; enddo + if (same_key) then + call MOM_mesg(trim(component)//": The same powers occur for "//& + trim(descs(n))//" and "//trim(descs(m))//"." ) + endif + enddo ; enddo + endif + + orig_cost = non_unique_scales(scales, list, descs, weights, silent=(verbosity<4)) + + max_itt = 3*ndims ! Do up to 3 iterations for each rescalable dimension. + if (orig_cost /= 0) then + call MOM_mesg(trim(component)//": The dimensional scaling factors are not unique.") + prev_cost = orig_cost + prev_scales(:) = scales(:) + do itt=1,max_itt + ! Iterate to find a better solution. + better_scales(:) = prev_scales(:) + better_cost = prev_cost + better_dp = 0 + do i=1,ndims + if (scales(i) == 0) cycle ! DO not optimize unscaled dimensions. + next_scales(:) = prev_scales(:) + do p=-max_pow,max_pow + if ((p==0) .or. (p==prev_scales(i))) cycle + next_scales(i) = p + test_cost = non_unique_scales(next_scales, list, descs, weights, silent=.true.) + if ((test_cost < better_cost) .or. & + ((test_cost == better_cost) .and. (abs(p-prev_scales(i)) < better_dp))) then + ! This is a better scaling or has the same weighted mismatches but smaller + ! changes in rescaling factors, so it could be the next guess. + better_scales(:) = next_scales(:) + better_cost = test_cost + better_dp = abs(p - prev_scales(i)) + endif + enddo + enddo + if (better_cost < prev_cost) then + ! Store the new best guess and try again. + prev_scales(:) = better_scales(:) + prev_cost = better_cost + else ! No further optimization is possible. + exit + endif + if (better_cost == 0) exit + if (verbosity >= 7) then + write(mesg, '("Iteration ",I2," scaling cost reduced from ",I8," with original scales to ", I8)') & + itt, orig_cost, better_cost + call MOM_mesg(trim(component)//": "//trim(mesg)//" with revised scaling factors.") + endif + enddo + if (prev_cost < orig_cost) then + test_cost = non_unique_scales(prev_scales, list, descs, weights, silent=(verbosity<4)) + mesg = trim(component)//": Suggested improved scales: " + do i=1,ndims ; if ((prev_scales(i) /= scales(i)) .and. (scales(i) /= 0)) then + write(msg_frag, '(I3)') prev_scales(i) + mesg = trim(mesg)//" "//trim(key(i))//"_RESCALE_POWER = "//trim(adjustl(msg_frag)) + endif ; enddo + call MOM_mesg(mesg) + + write(mesg, '(I8)') orig_cost + write(msg_frag, '(I8)') test_cost + mesg = trim(component)//": Scaling overlaps reduced from "//trim(adjustl(mesg))//& + " with original scales to "//trim(adjustl(msg_frag))//" with suggested scales." + call MOM_mesg(mesg) + endif + + endif + +end subroutine check_scaling_uniqueness + +!> Convert a unit scaling descriptor into an array of the dimensions of powers given in the key +subroutine encode_dim_powers(scaling, key, dim_powers) + + character(len=*), intent(in) :: scaling !< The unit description that will be converted + character(len=*), dimension(:), intent(in) :: key(:) !< The key for the unit scaling + integer, dimension(size(key)), intent(out) :: dim_powers !< The dimensions in scaling of each + !! element of they key. + + ! Local variables + character(len=:), allocatable :: actstr ! The full active remaining string to be parsed. + character(len=:), allocatable :: fragment ! The space-delimited fragment being parsed. + character(len=:), allocatable :: dimnm ! The probable dimension name + character(len=11) :: numbers ! The list of characters that could make up the exponent. + ! character(len=128) :: mesg + integer :: istart, iend, ieq, ief, ipow ! Positions in strings. + integer :: dp ! The power for this dimension. + integer :: ndim ! The number of dimensional scaling factors to consider. + integer :: n + + dim_powers(:) = 0 + + iend = index(scaling, "~>") - 1 + if (iend < 1) return + + ! Parse the key. + ndim = size(key) + numbers = "-0123456789" + + ! Strip away any leading square brace. + istart = index(scaling(:iend), "[") + 1 + ! If there is an "=" in the string, start after this. + ieq = index(scaling(istart:iend), "=", back=.true.) + if (ieq > 0) istart = istart + ieq + + ! Set up the active string to work on. + actstr = trim(adjustl(scaling(istart:iend))) + do ! Loop over each of the elements in the unit scaling descriptor. + if (len_trim(actstr) == 0) exit + ief = index(actstr, " ") - 1 + if (ief <= 0) ief = len_trim(actstr) + fragment = actstr(:ief) + ipow = scan(fragment, "-") + if (ipow == 0) ipow = scan(fragment, numbers) + + if (ipow == 0) then ! There is no exponent + dimnm = fragment + dp = 1 + ! call MOM_mesg("Parsing powerless fragment "//trim(fragment)//" from "//trim(scaling)) + else + if (verify(fragment(ipow:), numbers) == 0) then + read(fragment(ipow:),*) dp + dimnm = fragment(:ipow-1) + ! write(mesg, '(I3)') dp + ! call MOM_mesg("Parsed fragment "//trim(fragment)//" from "//trim(scaling)//& + ! " as "//trim(dimnm)//trim(adjustl(mesg))) + else + dimnm = fragment + dp = 1 + ! call MOM_mesg("Unparsed fragment "//trim(fragment)//" from "//trim(scaling)) + endif + endif + + do n=1,ndim + if (trim(dimnm) == trim(key(n))) then + dim_powers(n) = dim_powers(n) + dp + exit + endif + enddo + + ! Remove the leading fragment that has been parsed from actstr + actstr = trim(adjustl(actstr(ief+1:))) + enddo + +end subroutine encode_dim_powers + +!> Find the integer power of two that describe each of the scaling factors, or return 0 for +!! scaling factors that are not exceptionally close to an integer power of 2. +subroutine scales_to_powers(scale, pow2) + real, intent(in) :: scale(:) !< The scaling factor for each dimension + integer, intent(out) :: pow2(:) !< The exact powers of 2 for each scale, or 0 for non-exact powers of 2. + + real :: log2_sc ! The log base 2 of an element of scale + integer :: n, ndim + + ndim = size(scale) + + ! Find the integer power of two for the scaling factors, but skip the analysis of any factors + ! that are not close enough to being integer powers of 2. + do n=1,ndim + if (abs(scale(n)) > 0.0) then + log2_sc = log(abs(scale(n))) / log(2.0) + else + log2_sc = 0.0 + endif + if (abs(log2_sc - nint(log2_sc)) < 1.0e-6) then + ! This is close to an integer power of two. + pow2(n) = nint(log2_sc) + else + ! This is not being scaled by an integer power of 2, so return 0. + pow2(n) = 0 + endif + enddo + +end subroutine scales_to_powers + +!> Determine from the list of scaling factors and the unit combinations that are in use whether +!! all these combinations scale uniquely. +integer function non_unique_scales(scales, list, descs, weights, silent) + integer, intent(in) :: scales(:) !< The power of 2 that gives the scaling factor for each dimension + integer, intent(in) :: list(:,:) !< A list of the integers for each scaling + character(len=*), intent(in) :: descs(:) !< The unit descriptions that have been converted + integer, intent(in) :: weights(:) !< A list of the weights for each scaling + logical, optional, intent(in) :: silent !< If present and true, do not write any output. + + ! Local variables + integer, dimension(size(weights)) :: res_pow ! The net rescaling power for each combination. + integer, dimension(size(weights)) :: wt_merge ! The merged weights of scaling factors with common powers + ! for the dimensions being tested. + logical :: same_key, same_scales, verbose + character(len=256) :: mesg + integer :: nonzero_count ! The number of non-zero scaling factors + integer :: ndim ! The number of dimensional scaling factors to work with + integer :: i, n, m, ns + + verbose = .true. ; if (present(silent)) verbose = .not.silent + + ndim = size(scales) + ns = size(descs) + call assert((size(scales) == size(list, 1)), "non_unique_scales: Mismatched scales and list sizes.") + call assert((size(descs) == size(list, 2)), "non_unique_scales: Mismatched descs and list sizes.") + call assert((size(descs) == size(weights)), "non_unique_scales: Mismatched descs and weights.") + + ! Return .true. if all scaling powers are 0, or there is only one scaling factor in use. + nonzero_count = 0 ; do n=1,ndim ; if (scales(n) /= 0) nonzero_count = nonzero_count + 1 ; enddo + if (nonzero_count <= 1) return + + ! Figure out which unit combinations are unique for the set of dimensions and scaling factors + ! that are being tested, and combine the weights for scaling factors. + wt_merge(:) = weights(:) + do n=1,ns ; do m=1,n-1 + same_key = .true. + same_scales = .true. + do i=1,ndim + if (list(i,n) /= list(i,m)) same_key = .false. + if ((scales(i) /= 0) .and. (list(i,n) /= list(i,m))) same_scales = .false. + enddo + if (same_key .or. same_scales) then + if (wt_merge(n) > wt_merge(m)) then + wt_merge(n) = wt_merge(n) + wt_merge(m) + wt_merge(m) = 0 + else + wt_merge(m) = wt_merge(m) + wt_merge(n) + wt_merge(n) = 0 + endif + endif + if (wt_merge(n) == 0) exit ! Go to the next value of n. + enddo ; enddo + + do n=1,ns + res_pow(n) = 0 + do i=1,ndim + res_pow(n) = res_pow(n) + scales(i) * list(i,n) + enddo + enddo + + ! Determine the weighted cost of non-unique scaling factors. + non_unique_scales = 0 + do n=1,ns ; if (wt_merge(n) > 0) then ; do m=1,n-1 ; if (wt_merge(m) > 0) then + if (res_pow(n) == res_pow(m)) then + ! Use the product of the weights as the cost, as this should be vaguely proportional to + ! the likelihood that these factors would be combined in an expression. + non_unique_scales = min(non_unique_scales + wt_merge(n) * wt_merge(m), 99999999) + if (verbose) then + write(mesg, '(I8)') res_pow(n) + call MOM_mesg("The factors "//trim(descs(n))//" and "//trim(descs(m))//" both scale to "//& + trim(adjustl(mesg))//" for the given powers.") + + ! call MOM_mesg("Powers ["//trim(int_array_msg(list(:,n)))//"] and ["//& + ! trim(int_array_msg(list(:,m)))//"] with rescaling by ["//& + ! trim(int_array_msg(scales))//"]") + endif + endif + endif ; enddo ; endif ; enddo + +end function non_unique_scales + +!> Return a string the elements of an array of integers +function int_array_msg(array) + integer, intent(in) :: array(:) !< The array whose values are to be written. + character(len=16*size(array)) :: int_array_msg + + character(len=12) :: msg_frag + integer :: i, ni + ni = size(array) + + int_array_msg = "" + if (ni < 1) return + + do i=1,ni + write(msg_frag, '(I8)') array(i) + msg_frag = adjustl(msg_frag) + if (i == 1) then + int_array_msg = trim(msg_frag) + else + int_array_msg = trim(int_array_msg)//" "//trim(msg_frag) + endif + enddo +end function int_array_msg + +end module MOM_unique_scales diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index cd339f410c..bf8fd24b44 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -196,8 +196,11 @@ end subroutine set_unit_scaling_combos !> Set the unit scaling factors for output to restart files to the unit scaling !! factors for this run. -subroutine fix_restart_unit_scaling(US) +subroutine fix_restart_unit_scaling(US, unscaled) type(unit_scale_type), intent(inout) :: US !< A dimensional unit scaling type + logical, optional, intent(in) :: unscaled !< If true, set the restart factors as though the + !! model would be unscaled, which is appropriate if the + !! scaling is undone when writing a restart file. US%m_to_Z_restart = US%m_to_Z US%m_to_L_restart = US%m_to_L @@ -205,6 +208,14 @@ subroutine fix_restart_unit_scaling(US) US%kg_m3_to_R_restart = US%kg_m3_to_R US%J_kg_to_Q_restart = US%J_kg_to_Q + if (present(unscaled)) then ; if (unscaled) then + US%m_to_Z_restart = 1.0 + US%m_to_L_restart = 1.0 + US%s_to_T_restart = 1.0 + US%kg_m3_to_R_restart = 1.0 + US%J_kg_to_Q_restart = 1.0 + endif ; endif + end subroutine fix_restart_unit_scaling !> Deallocates a unit scaling structure. diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 9df994448b..5277cef1f6 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -138,7 +138,6 @@ subroutine write_cputime(day, n, CS, nmax, call_end) ! this subroutine. integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK real :: reday ! A real version of day. - character(len=256) :: mesg ! The text of an error message integer :: start_of_day, num_days if (.not.associated(CS)) call MOM_error(FATAL, & @@ -200,7 +199,7 @@ subroutine write_cputime(day, n, CS, nmax, call_end) (CS%startup_cputime / CLOCKS_PER_SEC), num_pes() write(CS%fileCPU_ascii,*)" Day, Step number, CPU time, CPU time change" endif - write(CS%fileCPU_ascii,'(F12.3,", "I11,", ", F12.3,", ", F12.3)') & + write(CS%fileCPU_ascii,'(F12.3,", ",I11,", ",F12.3,", ",F12.3)') & reday, n, (CS%cputime2 / real(CLOCKS_PER_SEC)), & d_cputime / real(CLOCKS_PER_SEC) diff --git a/src/framework/_Dimensional_consistency.dox b/src/framework/_Dimensional_consistency.dox new file mode 100644 index 0000000000..0657724381 --- /dev/null +++ b/src/framework/_Dimensional_consistency.dox @@ -0,0 +1,85 @@ +/*! \page Dimensional_consistency Dimensional Consistency Testing + +\section section_Dimensional_consistency Dimensional Consistency Testing + + MOM6 uses a unique system for testing the dimensional consistency of all of +its expressions. The internal representations of dimensional variables are +rescaled by integer powers of 2 that depend on their units, with all input and +output being rescaled back to their original MKS units. By choosing different +powers of 2 for different units, the internal representations with different +units scale differently, so dimensionally inconsistent expressions will not +reproduce, but dimensionally inconsistent expressions give bitwise identical +results. So, for example, if horizontal lengths scale by a factor of 2^6=64, +and time is scaled by a factor of 2^4=16, horizontal velocities will scale by a +factor of 2^(6-4)=4. In this case, expressions that combine velocities, all +terms would scale by the same factor of 4. By contrast, if there were an +expression where a variable with units of length were added to one with the +units of a velocity, the results would scale inconsistently, and answers would +change with different scaling factors. + + What makes these integer powers of 2 special is the way that floating point +numbers are written as an O(1) mantissa times 2 raised to an integer exponent +between +/-1024. Multiplication by an integer power of 2 is just an integer +shift in the exponent, so as long as the model is not rescaled by an overly +large factor to encounter overflows and the model is not relying on automatic +underflows being converted to 0, all floating point operations can be carried +with one scale, and then rescaled to obtain identical answers. MOM6 has the +option to explicitly handle all relevant cases of underflows, and it can be +demonstrated to give identical answers when each of its units are scaled by +factors ranging from 2^-140 ~= 7.2e-43 to 2^140 ~= 1.4e42. + + When running with rescaling factors other than 2^0 = 1, there are some extra +array copies and multiplies of input fields or diagnostic output, so it is +slightly more efficient not to actively use the dimensional rescaling. For +production runs, we typically set all of the rescaling powers to 0, but for +debugging code problems, this rescaling can be an invaluable tool, especially +when combined with the very verbose runtime setting DEBUG=True in a MOM_input or +MOM_override file. Diffs of the output from runs with different scaling factors +readily highlights the earliest instances of differences, which can be used to +track down any dimensionally inconsistent expressions. Similarly, dimensional +inconsistencies in diagnostics is easily tracked down by comparing the output +from a pair of runs. + + All real variables in MOM6 should have comments describing their purpose, +along with their rescaled units and their mks counterparts with notation like +"! A velocity [L T-1 ~> m s-1]". If the units vary with the Boussinesq +approximation, the Boussinesq variant is given first. When variables are read +in, their dimensions are usually specified with a 'scale=' optional argument on +the MOM_get_param or MOM_read_data call, while the unscaling of diagnostics is +specified with a 'conversion=' factor. In both cases, these arguments it next +to a text string specifying the variable's units, which can then be check easily +for self-consistency. + + Currently in MOM6, the following dimensions have unique scaling, along with +the notation used to describe these variables in comments: + +\li Time, scaled by 2^T_RESCALE_POWER, denoted as [T ~> s] +\li Horizontal length, scaled by 2^L_RESCALE_POWER, denoted as [L ~> m] +\li Vertical height, scaled by 2^Z_RESCALE_POWER, denoted as [Z ~> m] +\li Vertical thickness, scaled by 2^H_RESCALE_POWER, denoted as [H ~> m or kg m-2] +\li Density, scaled by 2^R_RESCALE_POWER, denoted as [R ~> kg m-3] +\li Enthalpy (or heat content), scaled by 2^Q_RESCALE_POWER, denoted as [Q ~> J kg-1] + + These rescaling capabilities are also used by the SIS2 sea ice model, but it +does uses a non-Boussinesq mass scale of [R Z ~> kg m-2] for ice thicknesses, +rather than having a separate scaling factor (of [H ~> m or kg m-2]) that varies +between the Boussinesq and non-Boussinesq modes like MOM6 does. The actual +powers used in the scaling are specified separately for MOM6 and SIS2 and +need not be the same. + + Each of these units can be scaled in separate test runs, or all of them can be +rescaled simultaneously. In the latter case, MOM_unique_scales.F90 provides +tools to evaluate whether the specific combinations of units used by a model +scale by unique powers, and it can suggest scaling factors that provides unique +combinations of rescaling factors for the dimensions being tested, using a +cost-function based on the frequency with which units are used in the model (and +specified inside of MOM_check_scaling.F90), with a cost going as the product of +the frequency of units that resolve to the same scaling factor. + + A separate set of scaling factors could also be used for different chemical +tracer concentrations, for example. In this case, the tools in +MOM_unique_scales.F90 could still be used, but there would need to be a separate +equivalent of the unit_scaling_type with variables that are appropriate to the +units of the tracers. + +*/ diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 new file mode 100644 index 0000000000..0a534db6c0 --- /dev/null +++ b/src/framework/posix.F90 @@ -0,0 +1,347 @@ +!> Interface to the libc POSIX API +#include "posix.h" + +module posix + +use, intrinsic :: iso_c_binding, only : c_char +use, intrinsic :: iso_c_binding, only : c_int +use, intrinsic :: iso_c_binding, only : c_long +use, intrinsic :: iso_c_binding, only : c_null_char +use, intrinsic :: iso_c_binding, only : c_funptr +use, intrinsic :: iso_c_binding, only : c_funloc +use, intrinsic :: iso_c_binding, only : c_f_procpointer + +implicit none + +!> Container for the jump point buffer created by setjmp(). +!! +!! The buffer typically contains the current register values, stack pointers, +!! and any information required to restore the process state. +type, bind(c) :: jmp_buf + private + character(kind=c_char) :: state(JMP_BUF_SIZE) + !< Unstructured array of bytes used to store the process state +end type jmp_buf + +!> Container for the jump point buffer (with signals) created by sigsetjmp() +!! +!! In addition to the content stored by `jmp_buf`, it also stores signal state. +type, bind(c) :: sigjmp_buf + private + character(kind=c_char) :: state(SIGJMP_BUF_SIZE) + !< Unstructured array of bytes used to store the process state +end type sigjmp_buf + +! POSIX signals +integer, parameter :: SIGUSR1 = POSIX_SIGUSR1 + !< Signal number for SIGUSR1 (user-defined signal 1) + +interface + !> C interface to POSIX chmod() + !! Users should use the Fortran-defined chmod() function. + function chmod_posix(path, mode) result(rc) bind(c, name="chmod") + ! #include + ! int chmod(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function chmod_posix + + !> C interface to POSIX signal() + !! Users should use the Fortran-defined signal() function. + function signal_posix(sig, func) result(handle) bind(c, name="signal") + ! #include + ! void (*signal(int sig, void (*func)(int)))(int); + import :: c_int, c_funptr + + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be configured + type(c_funptr), value, intent(in) :: func + !< Function handle to be called when `sig` is raised + type(c_funptr) :: handle + !< Prior handle for sig to be replaced by `func` + end function signal_posix + + !> C interface to POSIX kill() + !! Users should use the Fortran-defined kill() function. + function kill_posix(pid, sig) result(rc) bind(c, name="kill") + ! #include + ! int kill(pid_t pid, int sig); + import :: c_int + + integer(kind=c_int), value, intent(in) :: pid + !< Process ID which is to receive the signal + integer(kind=c_int), value, intent(in) :: sig + !< Signal to be sent to the process + integer(kind=c_int) :: rc + !< Function return code + end function kill_posix + + !> C interface to POSIX getpid() + !! Users should use the Fortran-defined getpid() function. + function getpid_posix() result(pid) bind(c, name="getpid") + ! #include + ! pid_t getpid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the current process. + end function getpid_posix + + !> C interface to POSIX getppid() + !! Users should use the Fortran-defined getppid() function. + function getppid_posix() result(pid) bind(c, name="getppid") + ! #include + ! pid_t getppid(void); + import :: c_long + + integer(kind=c_long) :: pid + !< Process ID of the parent process to the current process. + end function getppid_posix + + !> C interface to POSIX sleep() + !! Users should use the Fortran-defined sleep() function. + function sleep_posix(seconds) result(rc) bind(c, name="sleep") + ! #include + ! unsigned int sleep(unsigned int seconds); + import :: c_int + + integer(kind=c_int), value, intent(in) :: seconds + !< Number of real-time seconds which the thread should sleep + integer(kind=c_int) :: rc + !< Function return code + end function + + ! NOTE: The C setjmp and sigsetjmp functions *must* be called explicitly by + ! the Fortran code, rather than through a wrapper Fortran function. + ! + ! Otherwise, setjmp() will capture the stack inside the wrapper, rather than + ! the point where setjmp() is called. + ! + ! Hence, we remove the `_posix` suffix and call these explicitly. + ! (The integer kind <-> c_int conversion will need to be addressed.) + + ! NOTE: POSIX explicitly says setjmp/sigsetjmp may be either a function or a + ! macro, and thus bind() may point to a nonexistent function. + ! e.g. sigsetjmp is a macro to __sigsetjmp in glibc, so we use a macro. + + !> Save the current program execution state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + function setjmp(env) result(rc) bind(c, name="setjmp") + ! #include + ! int setjmp(jmp_buf env); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int) :: rc + !< Function return code; set to 0 if setjmp() was called, otherwise + !! specified by the corresponding longjmp() call. + end function setjmp + + !> Save the current execution and ,optionally, the signal state to `env`. + !! + !! This function creates a snapshot of the process state to `env`, which can + !! be restored by calling `longjmp`. When `setjmp` is called, the function + !! returns 0. When `longjmp` is later called, the program is restored to the + !! point where `setjmp` was called, except it now returns a value (rc) as + !! specified by `longjmp`. + !! + !! If `savesigs` is set to a nonzero value, then the signal state is included + !! in the program state. + function sigsetjmp(env, savesigs) result(rc) bind(c, name=SIGSETJMP_NAME) + ! #include + ! int sigsetjmp(jmp_buf env, int savesigs); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Current process state + integer(kind=c_int), value, intent(in) :: savesigs + !< Flag to enable signal state when set to a nonzero value + integer(kind=c_int) :: rc + !< Function return code; set to 0 if sigsetjmp() was called, otherwise + !! specified by the corresponding siglongjmp() call. + end function sigsetjmp + + !> C interface to POSIX longjmp() + !! Users should use the Fortran-defined longjmp() function. + subroutine longjmp_posix(env, val) bind(c, name="longjmp") + ! #include + ! int longjmp(jmp_buf env, int val); + import :: jmp_buf, c_int + + type(jmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to setjmp() + end subroutine longjmp_posix + + !> C interface to POSIX siglongjmp() + !! Users should use the Fortran-defined siglongjmp() function. + subroutine siglongjmp_posix(env, val) bind(c, name="longjmp") + ! #include + ! int siglongjmp(jmp_buf env, int val); + import :: sigjmp_buf, c_int + + type(sigjmp_buf), intent(in) :: env + !< Process state to restore + integer(kind=c_int), value, intent(in) :: val + !< Return code sent to sigsetjmp() + end subroutine siglongjmp_posix + + ! Note on types: + ! mode_t: + ! "According to POSIX, it shall be an integer type." + ! pid_t: + ! "According to POSIX, it shall be a signed integer type, and the + ! implementation shall support one or more programming environments where + ! the width of pid_t is no greater than the width of the type long. + ! jmp_buf: + ! This is a strongly platform-dependent variable, large enough to contain + ! a complete copy of the process execution state (registers, stack, etc). + ! sigjmp_buf: + ! A more comprehensive version of jmp_buf which contains signal state. +end interface + +abstract interface + !> Function interface for signal handlers + subroutine handler_interface(sig) + integer, intent(in) :: sig + !> Input signal to handler + end subroutine +end interface + +contains + +!> Change mode of a file +!! +!! This changes the file permission of file `path` to `mode` following POSIX +!! conventions. If successful, it returns zero. Otherwise, it returns -1. +function chmod(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = chmod_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function chmod + +!> Create a signal handler `handle` to be called when `sig` is detected. +!! +!! If successful, the previous handler for `sig` is returned. Otherwise, +!! SIG_ERR is returned. +function signal(sig, func) result(handle) + integer, intent(in) :: sig + procedure(handler_interface) :: func + procedure(handler_interface), pointer :: handle + + integer(kind=c_int) :: sig_c + type(c_funptr) :: handle_c + + sig_c = int(sig, kind=c_int) + handle_c = signal_posix(sig_c, c_funloc(func)) + call c_f_procpointer(handle_c, handle) +end function signal + +!> Send signal `sig` to process `pid`. +!! +!! If successful, this function returns 0. Otherwise, it returns -1. +function kill(pid, sig) result(rc) + integer, intent(in) :: pid + integer, intent(in) :: sig + integer :: rc + + integer(kind=c_int) :: pid_c, sig_c, rc_c + + pid_c = int(pid, kind=c_int) + sig_c = int(sig, kind=c_int) + rc_c = kill_posix(pid_c, sig_c) + rc = int(rc_c) +end function kill + +!> Get the ID of the current process. +function getpid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getpid_posix() + pid = int(pid_c) +end function getpid + +!> Get the ID of the parent process of the current process. +function getppid() result(pid) + integer :: pid + + integer(kind=c_long) :: pid_c + + pid_c = getppid_posix() + pid = int(pid_c) +end function getppid + +!> Force the process to a sleep state for `seconds` seconds. +!! +!! The sleep state may be interrupted by a signal. If it sleeps for the entire +!! duration, then it returns 0. Otherwise, it returns the number of seconds +!! remaining at the point of interruption. +function sleep(seconds) result(rc) + ! NOTE: This function may replace an existing compiler `sleep()` extension. + integer, intent(in) :: seconds + integer :: rc + + integer(kind=c_int) :: seconds_c + integer(kind=c_int) :: rc_c + + seconds_c = int(seconds, kind=c_int) + rc_c = sleep_posix(seconds_c) + rc = int(rc_c) +end function sleep + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved +!! back to this `setjmp`, except the function will now return `val`. +subroutine longjmp(env, val) + type(jmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call longjmp_posix(env, val_c) +end subroutine longjmp + +!> Restore program to state saved by `env`, and return the value `val`. +!! +!! This "nonlocal goto" alters program execution to the state stored in `env` +!! produced by a prior execution of `setjmp`. Program execution is moved back +!! to this `setjmp`, except the function will now return `val`. +!! +!! `siglongjmp` behaves in the same manner as `longjmp`, but also provides +!! predictable handling of the signal state. +subroutine siglongjmp(env, val) + type(sigjmp_buf), intent(in) :: env + integer, intent(in) :: val + + integer(kind=c_int) :: val_c + + val_c = int(val, kind=c_int) + call siglongjmp_posix(env, val_c) +end subroutine siglongjmp + +end module posix diff --git a/src/framework/posix.h b/src/framework/posix.h new file mode 100644 index 0000000000..6d6012c5e7 --- /dev/null +++ b/src/framework/posix.h @@ -0,0 +1,28 @@ +#ifndef MOM6_POSIX_H_ +#define MOM6_POSIX_H_ + +! JMP_BUF_SIZE should be set to sizeof(jmp_buf). +! If unset, then use a typical glibc value (25 long ints) +#ifndef JMP_BUF_SIZE +#define JMP_BUF_SIZE 200 +#endif + +! If unset, assume jmp_buf and sigjmp_buf are equivalent (as in glibc). +#ifndef SIGJMP_BUF_SIZE +#define SIGJMP_BUF_SIZE JMP_BUF_SIZE +#endif + +! glibc defines sigsetjmp as __sigsetjmp via macro readable from . +! Perhaps autoconf can configure this one... +! TODO: Need a solution here! +#ifndef SIGSETJMP_NAME +#define SIGSETJMP_NAME "__sigsetjmp" +#endif + +! This should be defined by /usr/include/signal.h +! If unset, we use the most common (x86) value +#ifndef POSIX_SIGUSR1 +#define POSIX_SIGUSR1 10 +#endif + +#endif diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 13af5a936a..10aef884dd 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -9,6 +9,7 @@ module MOM_ice_shelf use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_ROUTINE use MOM_coms, only : num_PEs +use MOM_data_override, only : data_override use MOM_diag_mediator, only : MOM_diag_ctrl=>diag_ctrl use MOM_IS_diag_mediator, only : post_data=>post_IS_data use MOM_IS_diag_mediator, only : register_diag_field=>register_MOM_IS_diag_field, safe_alloc_ptr @@ -135,7 +136,7 @@ module MOM_ice_shelf !!!! PHYSICAL AND NUMERICAL PARAMETERS FOR ICE DYNAMICS !!!!!! - real :: time_step !< this is the shortest timestep that the ice shelf sees, and + real :: time_step !< this is the shortest timestep that the ice shelf sees [T ~> s], and !! is equal to the forcing timestep (it is passed in when the shelf !! is initialized - so need to reorganize MOM driver. !! it will be the prognistic timestep ... maybe. @@ -152,14 +153,17 @@ module MOM_ice_shelf real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: T0 !< temperature at ocean surface in the restoring region [degC] real :: S0 !< Salinity at ocean surface in the restoring region [ppt]. - real :: input_flux !< Ice volume flux at an upstream open boundary [m3 s-1]. - real :: input_thickness !< Ice thickness at an upstream open boundary [m]. + real :: input_flux !< The vertically integrated inward ice thickness flux per + !! unit face length at an upstream boundary [Z L T-1 ~> m2 s-1] + real :: input_thickness !< Ice thickness at an upstream open boundary [Z ~> m]. type(time_type) :: Time !< The component's time. type(EOS_type) :: eqn_of_state !< Type that indicates the !! equation of state to use. logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result !! the dynamic ice-shelf model. + logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be + !! written using the data_override feature (only for MOSAIC grids) logical :: override_shelf_movement !< If true, user code specifies the shelf movement !! instead of using the dynamic ice-shelf mode. logical :: isthermo !< True if the ice shelf can exchange heat and @@ -188,7 +192,8 @@ module MOM_ice_shelf id_h_shelf = -1, id_h_mask = -1, & id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & - id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1 + id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & + id_shelf_sfc_mass_flux = -1 !>@} integer :: id_read_mass !< An integer handle used in time interpolation of @@ -307,7 +312,6 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true, the grouding line position is determined based on ! coupled ice-ocean dynamics. - logical :: use_temperature = .true. ! real, parameter :: c2_3 = 2.0/3.0 character(len=160) :: mesg ! The text of an error message @@ -321,9 +325,14 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) G => CS%grid ; US => CS%US ISS => CS%ISS + if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then + call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & + scale=US%kg_m2s_to_RZ_T) + endif + if (CS%rotate_index) then allocate(sfc_state) - call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state, CS%Grid, CS%turns) + call rotate_surface_state(sfc_state_in, sfc_state, CS%Grid, CS%turns) allocate(fluxes) call allocate_forcing_type(fluxes_in, G, fluxes) call rotate_forcing(fluxes_in, fluxes, CS%turns) @@ -359,7 +368,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) CS%Time = Time if (CS%override_shelf_movement) then - CS%time_step = time_step + CS%time_step = US%s_to_T*time_step ! update shelf mass if (CS%mass_from_file) call update_shelf_mass(G, US, CS, ISS, Time) endif @@ -730,6 +739,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using melt", G%HI, haloshift=0, & scale=US%RZ_to_kg_m2) endif + + call change_thickness_using_precip(CS, ISS, G, US, fluxes, US%s_to_T*time_step, Time) + + if (CS%debug) then + call hchksum(ISS%h_shelf, "h_shelf after change thickness using surf acc", G%HI, haloshift=0, scale=US%Z_to_m) + call hchksum(ISS%mass_shelf, "mass_shelf after change thickness using surf acc", G%HI, haloshift=0, & + scale=US%RZ_to_kg_m2) + endif + endif if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) @@ -753,6 +771,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, 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_ustar_shelf > 0) call post_data(CS%id_ustar_shelf, fluxes%ustar_shelf, CS%diag) + if (CS%id_shelf_sfc_mass_flux > 0) call post_data(CS%id_shelf_sfc_mass_flux, fluxes%shelf_sfc_mass_flux, CS%diag) + if (CS%id_melt > 0) call post_data(CS%id_melt, fluxes%iceshelf_melt, CS%diag) if (CS%id_thermal_driving > 0) call post_data(CS%id_thermal_driving, (sfc_state%sst-ISS%tfreeze), CS%diag) if (CS%id_Sbdry > 0) call post_data(CS%id_Sbdry, Sbdry, CS%diag) @@ -772,7 +792,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step, CS) call cpu_clock_end(id_clock_shelf) if (CS%rotate_index) then -! call rotate_surface_state(sfc_state,CS%Grid, sfc_state_in,CS%Grid_in,-CS%turns) +! call rotate_surface_state(sfc_state, sfc_state_in, CS%Grid_in, -CS%turns) call rotate_forcing(fluxes,fluxes_in,-CS%turns) endif @@ -951,8 +971,7 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) type(ocean_grid_type), pointer :: G => NULL() ! A pointer to ocean's grid structure. real :: press_ice !< The pressure of the ice shelf per unit area of ocean (not ice) [R L2 T-2 ~> Pa]. - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - + integer :: i, j, is, ie, js, je G=>CS%Grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1089,7 +1108,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) ! take into account changes in mass (or thickness) when imposing ice shelf mass if (CS%override_shelf_movement .and. CS%mass_from_file) then - dTime = real_to_time(CS%time_step) + dTime = real_to_time(US%T_to_s*CS%time_step) ! Compute changes in mass after at least one full time step if (CS%Time > dTime) then @@ -1124,8 +1143,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) delta_float_mass(i,j) = 0.0 endif enddo ; enddo - delta_mass_shelf = US%kg_m2s_to_RZ_T*(global_area_integral(delta_float_mass, G, scale=US%RZ_to_kg_m2, & - area=ISS%area_shelf_h) / CS%time_step) + delta_mass_shelf = global_area_integral(delta_float_mass, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) / CS%time_step else! first time step delta_mass_shelf = 0.0 endif @@ -1146,8 +1165,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) balancing_area = global_area_integral(bal_frac, G) if (balancing_area > 0.0) then - balancing_flux = ( US%kg_m2s_to_RZ_T*global_area_integral(ISS%water_flux, G, scale=US%RZ_T_to_kg_m2s, & - area=ISS%area_shelf_h) + & + balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & + area=ISS%area_shelf_h) + & delta_mass_shelf ) / balancing_area else balancing_flux = 0.0 @@ -1164,7 +1183,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) enddo ; enddo if (CS%debug) then - write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, CS%time_step + write(mesg,*) 'Balancing flux (kg/(m^2 s)), dt = ', balancing_flux*US%RZ_T_to_kg_m2s, US%T_to_s*CS%time_step call MOM_mesg(mesg) call MOM_forcing_chksum("After constant sea level", fluxes, G, CS%US, haloshift=0) endif @@ -1201,7 +1220,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, !! the ice-shelf state type(directories) :: dirs type(dyn_horgrid_type), pointer :: dG => NULL() - type(dyn_horgrid_type), pointer :: dG_in => NULL() real :: Z_rescale ! A rescaling factor for heights from the representation in ! a restart file to the internal representation in this run. real :: RZ_rescale ! A rescaling factor for mass loads from the representation in @@ -1212,11 +1230,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, real :: dz_ocean_min_float ! The minimum ocean thickness above which the ice shelf is considered ! to be floating when CONST_SEA_LEVEL = True [Z ~> m]. real :: cdrag, drag_bg_vel - logical :: new_sim, save_IC, var_force + logical :: new_sim, save_IC !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config - character(len=200) :: IC_file,filename,inputdir + character(len=200) :: IC_file, inputdir character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) @@ -1228,8 +1245,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! does not occur [Z ~> m] real, allocatable, dimension(:,:) :: tmp2d ! Temporary array for storing ice shelf input data - type(mech_forcing), pointer :: forces => NULL() - type(forcing), pointer :: fluxes => NULL() type(surface), pointer :: sfc_state => NULL() type(vardesc) :: u_desc, v_desc @@ -1265,7 +1280,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, allocate(CS%Grid) call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in') -! allocate(CS%Grid_in%HI) + !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) call MOM_grid_init(CS%Grid, param_file, CS%US) @@ -1354,6 +1369,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) CS%active_shelf_dynamics = .not.CS%override_shelf_movement + call get_param(param_file, mdl, "DATA_OVERRIDE_SHELF_FLUXES", & + CS%data_override_shelf_fluxes, & + "If true, the data override feature is used to write "//& + "the surface mass flux deposition. This option is only "//& + "available for MOSAIC grid types.", default=.false.) call get_param(param_file, mdl, "GROUNDING_LINE_INTERPOLATE", CS%GL_regularize, & "If true, regularize the floatation condition at the "//& "grounding line as in Goldberg Holland Schoof 2009.", default=.false.) @@ -1462,15 +1482,15 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%constant_sea_level) CS%min_ocean_mass_float = dz_ocean_min_float*CS%Rho_ocn call get_param(param_file, mdl, "ICE_SHELF_FLUX_FACTOR", CS%flux_factor, & - "Non-dimensional factor applied to shelf thermodynamic "//& - "fluxes.", units="none", default=1.0) + "Non-dimensional factor applied to shelf thermodynamic fluxes.", & + units="none", default=1.0) call get_param(param_file, mdl, "KV_ICE", CS%kv_ice, & "The viscosity of the ice.", & units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the "//& - "freezing temperature.", units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) + "The molecular kinimatic viscosity of sea water at the freezing temperature.", & + units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", units="psu", & default=0.0) @@ -1486,7 +1506,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DT_FORCING", CS%time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=0.0) + "The default value is given by DT.", units="s", default=0.0, scale=US%s_to_T) call get_param(param_file, mdl, "COL_THICK_MELT_THRESHOLD", col_thick_melt_thresh, & "The minimum ocean column thickness where melting is allowed.", & @@ -1504,7 +1524,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call allocate_surface_state(sfc_state_in, CS%Grid_in, use_temperature=.true., & do_integrals=.true., omit_frazil=.false., use_iceshelves=.true.) if (CS%rotate_index) then - call rotate_surface_state(sfc_state_in, CS%Grid_in, sfc_state,CS%Grid,CS%turns) + call rotate_surface_state(sfc_state_in, sfc_state,CS%Grid, CS%turns) else sfc_state=>sfc_state_in endif @@ -1546,9 +1566,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "INPUT_FLUX_ICE_SHELF", CS%input_flux, & - "volume flux at upstream boundary", units="m2 s-1", default=0.) + "volume flux at upstream boundary", units="m2 s-1", default=0., scale=US%m_to_Z*US%m_s_to_L_T) call get_param(param_file, mdl, "INPUT_THICK_ICE_SHELF", CS%input_thickness, & - "flux thickness at upstream boundary", units="m", default=1000.) + "flux thickness at upstream boundary", units="m", default=1000., scale=US%m_to_Z) else ! This is here because of inconsistent defaults. I don't know why. RWH call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & @@ -1634,11 +1654,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call restart_init(param_file, CS%restart_CSp, "Shelf.res") call register_restart_field(ISS%mass_shelf, "shelf_mass", .true., CS%restart_CSp, & - "Ice shelf mass", "kg m-2") + "Ice shelf mass", "kg m-2", conversion=US%RZ_to_kg_m2) call register_restart_field(ISS%area_shelf_h, "shelf_area", .true., CS%restart_CSp, & - "Ice shelf area in cell", "m2") + "Ice shelf area in cell", "m2", conversion=US%L_to_m**2) call register_restart_field(ISS%h_shelf, "h_shelf", .true., CS%restart_CSp, & - "ice sheet/shelf thickness", "m") + "ice sheet/shelf thickness", "m", conversion=US%Z_to_m) if (PRESENT(sfc_state_in)) then if (allocated(sfc_state%taux_shelf) .and. allocated(sfc_state%tauy_shelf)) then u_desc = var_desc("taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & @@ -1646,7 +1666,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, v_desc = var_desc("tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & hor_grid='Cv',z_grid='1') call register_restart_pair(sfc_state%taux_shelf, sfc_state%tauy_shelf, u_desc, v_desc, & - .false., CS%restart_CSp) + .false., CS%restart_CSp, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif endif @@ -1663,13 +1683,13 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%active_shelf_dynamics) then ! Allocate CS%dCS and specify additional restarts for ice shelf dynamics - call register_ice_shelf_dyn_restarts(CS%Grid_in, param_file, CS%dCS, CS%restart_CSp) + call register_ice_shelf_dyn_restarts(CS%Grid_in, US, param_file, CS%dCS, CS%restart_CSp) endif !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file !if (.not. CS%solo_ice_sheet) then ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & - ! "Friction velocity under ice shelves", "m s-1") + ! "Friction velocity under ice shelves", "m s-1", conversion=###) !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1698,23 +1718,23 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: Restoring ice shelf from file.") call restore_state(dirs%input_filename, dirs%restart_input_dir, Time, G, CS%restart_CSp) - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%h_shelf(i,j) = Z_rescale * ISS%h_shelf(i,j) enddo ; enddo endif if ((US%m_to_Z_restart*US%kg_m3_to_R_restart /= 0.0) .and. & - (US%m_to_Z*US%kg_m3_to_R /= US%m_to_Z_restart * US%kg_m3_to_R_restart)) then - RZ_rescale = US%m_to_Z*US%kg_m3_to_R / (US%m_to_Z_restart * US%kg_m3_to_R_restart) + (US%m_to_Z_restart*US%kg_m3_to_R_restart /= 1.0)) then + RZ_rescale = 1.0 / (US%m_to_Z_restart * US%kg_m3_to_R_restart) do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%mass_shelf(i,j) = RZ_rescale * ISS%mass_shelf(i,j) enddo ; enddo endif - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) then - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) then + L_rescale = 1.0 / US%m_to_L_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec ISS%area_shelf_h(i,j) = L_rescale**2 * ISS%area_shelf_h(i,j) enddo ; enddo @@ -1815,6 +1835,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (CS%active_shelf_dynamics) then CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, & 'ice shelf thickness mask', 'none') + CS%id_shelf_sfc_mass_flux = register_diag_field('ice_shelf_model', 'sfc_mass_flux', CS%diag%axesT1, CS%Time, & + 'ice shelf surface mass flux deposition from atmosphere', 'none', conversion=US%RZ_T_to_kg_m2s) endif call MOM_IS_diag_mediator_close_registration(CS%diag) @@ -1845,7 +1867,7 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo) + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation = CS%active_shelf_dynamics) 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.) @@ -1975,6 +1997,57 @@ subroutine initialize_shelf_mass(G, param_file, CS, ISS, new_sim) end select end subroutine initialize_shelf_mass +!> This subroutine applies net accumulation/ablation at the top surface to the dynamic ice shelf. +!>>acc_rate[m-s]=surf_mass_flux/density_ice is ablation/accumulation rate +!>>positive for accumulation negative for ablation +subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time) + type(ice_shelf_CS), intent(in) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ice_shelf_state), intent(inout) :: ISS !< A structure with elements that describe + !! the ice-shelf state + type(forcing), intent(in) :: fluxes !< A structure of surface fluxes that + !! includes surface mass flux + type(time_type), intent(in) :: Time !< The current model time + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: time_step !< The time step for this update [T ~> s]. + + ! locals + integer :: i, j + real ::I_rho_ice + + I_rho_ice = 1.0 / CS%density_ice + + !update time +! CS%Time = Time + + +! CS%time_step = time_step + ! update surface mass flux rate +! if (CS%surf_mass_flux_from_file) call update_surf_mass_flux(G, US, CS, ISS, 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 + 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 + ! NOTE: this is not mass conservative should maybe scale salt & heat flux for this cell + ISS%h_shelf(i,j) = 0.0 + ISS%hmask(i,j) = 0.0 + ISS%area_shelf_h(i,j) = 0.0 + endif + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + endif + enddo ; enddo + + 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 change_thickness_using_precip + !> Updates the ice shelf mass using data from a file. subroutine update_shelf_mass(G, US, CS, ISS, Time) @@ -2032,12 +2105,13 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) end subroutine update_shelf_mass !> Save the ice shelf restart file -subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf) +subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf, data_override_shelf_fluxes) type(ice_shelf_CS), pointer :: CS !< ice shelf control structure type(ocean_grid_type), intent(in) :: G !< A pointer to an ocean grid control structure. - real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nodim]. - real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] - + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: frac_shelf_h !< Ice shelf area fraction [nondim]. + real, optional, dimension(SZI_(G),SZJ_(G)), intent(out) :: mass_shelf ! kg m-2] + logical, optional :: data_override_shelf_fluxes !< If true, shelf fluxes can be written using + !! the data_override capability (only for MOSAIC grids) integer :: i, j @@ -2055,6 +2129,11 @@ subroutine ice_shelf_query(CS, G, frac_shelf_h, mass_shelf) enddo ; enddo endif + if (present(data_override_shelf_fluxes)) then + data_override_shelf_fluxes=.false. + if (CS%active_shelf_dynamics) data_override_shelf_fluxes = CS%data_override_shelf_fluxes + endif + end subroutine ice_shelf_query !> Save the ice shelf restart file @@ -2115,7 +2194,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grouding line position is determined based on ! coupled ice-ocean dynamics. - integer :: is, iec, js, jec, i, j + integer :: is, iec, js, jec G => CS%grid US => CS%US diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index ef4ad7b6d9..778ac2ef12 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -105,8 +105,7 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) ! This subroutine sets up the grid and axis information for use by the ice shelf model. ! Local variables - integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_ct, id_ct0 - integer :: k + integer :: id_xq, id_yq, id_xh, id_yh logical :: Cartesian_grid character(len=80) :: grid_config, units_temp, set_name ! This include declares and sets the variable "version". @@ -531,7 +530,6 @@ integer function register_MOM_IS_static_field(module_name, field_name, axes, & integer, optional, intent(in) :: tile_count !< no clue (not used in MOM_IS?) ! Local variables - character(len=240) :: mesg real :: MOM_missing_value integer :: primary_id, fms_id type(diag_ctrl), pointer :: diag_cs !< A structure that is used to regulate diagnostic output @@ -564,7 +562,7 @@ subroutine describe_option(opt_name, value, diag_CS) ! Local variables character(len=240) :: mesg - integer :: start_ind = 1, end_ind, len_ind + integer :: len_ind len_ind = len_trim(value) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8fb674e36c..7847da55fa 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -224,8 +224,9 @@ end function quad_area !> This subroutine is used to register any fields related to the ice shelf !! dynamics that should be written to or read from the restart file. -subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) +subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(inout) :: G !< The grid type describing the ice shelf grid. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct @@ -275,20 +276,24 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) allocate( CS%h_bdry_val(isd:ied,jsd:jed), source=0.0 ) ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & - "ice sheet/shelf u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_shelf, "v_shelf", .false., restart_CS, & - "ice sheet/shelf v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_bdry_val, "u_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary u-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary u-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%v_bdry_val, "v_bdry_val", .false., restart_CS, & - "ice sheet/shelf boundary v-velocity", "m s-1", hor_grid='Bu') + "ice sheet/shelf boundary v-velocity", & + units="m s-1", conversion=US%L_T_to_m_s, hor_grid='Bu') call register_restart_field(CS%u_face_mask_bdry, "u_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary u-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%v_face_mask_bdry, "v_face_mask_bdry", .false., restart_CS, & "ice sheet/shelf boundary v-mask", "nondim", hor_grid='Bu') call register_restart_field(CS%OD_av, "OD_av", .true., restart_CS, & - "Average open ocean depth in a cell","m") + "Average open ocean depth in a cell", "m", conversion=US%Z_to_m) call register_restart_field(CS%ground_frac, "ground_frac", .true., restart_CS, & "fractional degree of grounding", "nondim") call register_restart_field(CS%C_basal_friction, "C_basal_friction", .true., restart_CS, & @@ -296,7 +301,7 @@ subroutine register_ice_shelf_dyn_restarts(G, param_file, CS, restart_CS) call register_restart_field(CS%AGlen_visc, "AGlen_visc", .true., restart_CS, & "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & - "ice thickness at the boundary","m") + "ice thickness at the boundary", "m", conversion=US%Z_to_m) endif end subroutine register_ice_shelf_dyn_restarts @@ -304,7 +309,6 @@ end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -324,13 +328,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! in a restart file to the internal representation in this run. !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: config character(len=200) :: IC_file,filename,inputdir character(len=40) :: var_name character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics logical :: debug - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -462,16 +465,16 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! Take additional initialization steps, for example of dependent variables. if (active_shelf_dynamics .and. .not.new_sim) then - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) then - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= 1.0)) then + Z_rescale = 1.0 / US%m_to_Z_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%OD_av(i,j) = Z_rescale * CS%OD_av(i,j) enddo ; enddo endif if ((US%m_to_L_restart*US%s_to_T_restart /= 0.0) .and. & - (US%m_to_L_restart /= US%m_s_to_L_T*US%s_to_T_restart)) then - vel_rescale = US%m_s_to_L_T*US%s_to_T_restart / US%m_to_L_restart + (US%m_to_L_restart /= US%s_to_T_restart)) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do J=G%jsc-1,G%jec ; do I=G%isc-1,G%iec CS%u_shelf(I,J) = vel_rescale * CS%u_shelf(I,J) CS%v_shelf(I,J) = vel_rescale * CS%v_shelf(I,J) @@ -535,31 +538,31 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif ! 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) - - ! initialize ice-stiffness AGlen - call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) - - !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) - - !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%bed_elev, G%domain,CENTER) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) - endif + 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) + + ! initialize ice-stiffness AGlen + call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call pass_var(CS%AGlen_visc, G%domain) + + !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) + + !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%bed_elev, G%domain,CENTER) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) + endif ! Register diagnostics. CS%id_u_shelf = register_diag_field('ice_shelf_model','u_shelf',CS%diag%axesB1, Time, & 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) @@ -623,7 +626,7 @@ subroutine initialize_diagnostic_fields(CS, ISS, G, US, Time) enddo enddo - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) end subroutine initialize_diagnostic_fields !> This function returns the global maximum advective timestep that can be taken based on the current @@ -686,58 +689,58 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! - call ice_shelf_advect(CS, ISS, G, time_step, Time) - CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step - if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. - - if (coupled_GL) then - call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) - elseif (update_ice_vel) then - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - endif - - - if (update_ice_vel) then - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) - endif - -! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - - if (update_ice_vel) 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(:,:) - 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(:,:) - 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) - if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) - if (CS%id_visc_shelf > 0) then - ice_visc(:,:)=CS%ice_visc(:,:)*G%IareaT(:,:) - call post_data(CS%id_visc_shelf, ice_visc,CS%diag) - endif - if (CS%id_taub > 0) then - basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) - call post_data(CS%id_taub, basal_tr,CS%diag) - endif + call ice_shelf_advect(CS, ISS, G, time_step, Time) + CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. + + if (coupled_GL) then + call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) + elseif (update_ice_vel) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif + + + if (update_ice_vel) then + call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + endif + +! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) + + if (update_ice_vel) 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(:,:) + 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(:,:) + 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) + if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) + if (CS%id_visc_shelf > 0) then + ice_visc(:,:) = CS%ice_visc(:,:)*G%IareaT(:,:) + call post_data(CS%id_visc_shelf, ice_visc, CS%diag) + endif + if (CS%id_taub > 0) then + basal_tr(:,:) = CS%basal_traction(:,:)*G%IareaT(:,:) + call post_data(CS%id_taub, basal_tr, CS%diag) + endif !! - if (CS%id_u_mask > 0) call post_data(CS%id_u_mask,CS%umask,CS%diag) - if (CS%id_v_mask > 0) call post_data(CS%id_v_mask,CS%vmask,CS%diag) - if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask,CS%u_face_mask_bdry,CS%diag) - if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask,CS%v_face_mask_bdry,CS%diag) -! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask,CS%tmask,CS%diag) + if (CS%id_u_mask > 0) call post_data(CS%id_u_mask, CS%umask, CS%diag) + if (CS%id_v_mask > 0) call post_data(CS%id_v_mask, CS%vmask, CS%diag) + if (CS%id_ufb_mask > 0) call post_data(CS%id_ufb_mask, CS%u_face_mask_bdry, CS%diag) + if (CS%id_vfb_mask > 0) call post_data(CS%id_vfb_mask, CS%v_face_mask_bdry, CS%diag) +! if (CS%id_t_mask > 0) call post_data(CS%id_t_mask, CS%tmask, CS%diag) - call disable_averaging(CS%diag) + call disable_averaging(CS%diag) - CS%elapsed_velocity_time = 0.0 - endif + CS%elapsed_velocity_time = 0.0 + endif end subroutine update_ice_shelf @@ -831,7 +834,7 @@ end subroutine ice_shelf_advect !>This subroutine computes u- and v-velocities of the ice shelf iterating on non-linear ice viscosity !subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, iters, time) - subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) +subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, iters, Time) type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe !! the ice-shelf state @@ -851,7 +854,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: err_u, err_v real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice @@ -859,14 +861,12 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv + real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell vertices [m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] - character(2) :: iternum - character(2) :: numproc ! for GL interpolation nsub = CS%n_sub_regularize @@ -895,7 +895,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) -! call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) + call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) ! This is to determine which cells contain the grounding line, the criterion being that the cell ! is ice-covered, with some nodes floating and some grounded flotation condition is estimated by ! assuming topography is cellwise constant and H is bilinear in a cell; floating where @@ -943,7 +943,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied ! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -996,8 +996,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) +! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1101,7 +1101,6 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H !! iterations have converged to the specified tolerance integer, intent(out) :: iters !< The number of iterations used in the solver. type(time_type), intent(in) :: Time !< The current model time - character(len=160) :: mesg ! The text of an error message real, dimension(8,4,SZDI_(G),SZDJ_(G)), & intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. @@ -1128,8 +1127,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] sum_vec, sum_vec_2 - real :: tol, beta_k, area, dot_p1, resid0, cg_halo - real :: num, denom + real :: beta_k, dot_p1, resid0, cg_halo real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] ! [m2 L-2 ~> 1] [R L3 Z T-2 ~> m kg s-2] @@ -1366,7 +1364,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H enddo call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - if (conv_flag == 0) then + if (conv_flag == 0) then iters = CS%cg_max_iterations endif @@ -1575,7 +1573,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ! o--- (3) ---o ! - integer :: i, j, isc, iec, jsc, jec, n_flux, k, l, iter_count + integer :: i, j, isc, iec, jsc, jec, n_flux, k, iter_count integer :: i_off, j_off integer :: iter_flag @@ -1816,13 +1814,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real :: dxh, dyh,Dx,Dy ! Local grid spacing [L ~> m] real :: grav ! The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq + integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd + isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed iegq = G%iegB ; jegq = G%jegB ! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 @@ -1842,6 +1841,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo do i=isc-G%domain%nihalo,iec+G%domain%nihalo if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then @@ -1851,6 +1851,13 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif enddo enddo + + call pass_var(S, G%domain) + allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + do j=jscq,jecq ; do i=iscq,iecq + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) + enddo ; enddo + do j=jsc-1,jec+1 do i=isc-1,iec+1 cnt = 0 @@ -1996,6 +2003,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif enddo enddo + + deallocate(Phi) end subroutine calc_shelf_driving_stress subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) @@ -2018,7 +2027,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new ! computational domain -- if this function gets moves to another module, ! DO NOT TAKE THE RESTARTING BIT WITH IT integer :: i, j , isd, jsd, ied, jed - integer :: gjec, gisc, gjsc, cnt, isc, jsc, iec, jec + integer :: isc, jsc, iec, jec integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2303,7 +2312,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground - integer :: i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt + integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2387,7 +2396,7 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_gr real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] - integer :: nsub, i, j, k, l, qx, qy, m, n + integer :: nsub, i, j, qx, qy, m, n nsub = size(Phisub,1) subarea = 1.0 / (nsub**2) @@ -2449,7 +2458,6 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real, dimension(2) :: xquad real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - real :: area real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt @@ -2573,12 +2581,11 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" ! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq, iq, jq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js, i_off, j_off + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js, i_off, j_off real :: Visc_coef, n_g real :: ux, uy, vx, vy - real :: eps_min, dxh, dyh ! Velocity shears [T-1 ~> s-1] + real :: eps_min ! Velocity shears [T-1 ~> s-1] ! real, dimension(8,4) :: Phi - real, dimension(2) :: xquad ! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2592,18 +2599,18 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - do j=jsc,jec ; do i=isc,iec +! do j=jsc,jec ; do i=isc,iec + do j=jscq,jecq ; do i=iscq,iecq call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:)=1e22 ! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) - do j=jsc,jec - do i=isc,iec + do j=jsc,jec ; do i=isc,iec - if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) + if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then + Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) do iq=1,2 ; do jq=1,2 @@ -2626,13 +2633,12 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - enddo ; enddo -! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + enddo ; enddo +! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - endif - enddo - enddo + endif + enddo ; enddo deallocate(Phi) end subroutine calc_shelf_visc @@ -2652,7 +2658,7 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) ! this may be subject to change later... to make it "hybrid" integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq - integer :: giec, gjec, gisc, gjsc, cnt, isc, jsc, iec, jec, is, js + integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -2726,7 +2732,7 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: h_shelf !< the thickness of the ice shelf [Z ~> m]. - integer :: i, j, iters, isd, ied, jsd, jed + integer :: i, j, isd, ied, jsd, jed real :: rhoi_rhow, OD rhoi_rhow = CS%density_ice / CS%density_ocean_avg @@ -2778,7 +2784,7 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) real, dimension(4) :: xquad, yquad ! [nondim] real :: a,b,c,d ! Various lengths [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) @@ -2840,22 +2846,22 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) real, dimension(4) :: xquad, yquad ! [nondim] real :: a, d ! Interpolated grid spacings [L ~> m] real :: xexp, yexp ! [nondim] - integer :: node, qpoint, xnode, xq, ynode, yq + integer :: node, qpoint, xnode, ynode xquad(1:3:2) = .5 * (1-sqrt(1./3)) ; yquad(1:2) = .5 * (1-sqrt(1./3)) xquad(2:4:2) = .5 * (1+sqrt(1./3)) ; yquad(3:4) = .5 * (1+sqrt(1./3)) do qpoint=1,4 - if (J>1) then + if (J>1) then a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) - else - a= G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) - endif - if (I>1) then + else + a = G%dxCv(i,J) !* yquad(qpoint) ! d(x)/d(x*) + endif + if (I>1) then d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) - else + else d = G%dyCu(I,j) !* xquad(qpoint) - endif + endif ! a = G%dxCv(i,J-1) * (1-yquad(qpoint)) + G%dxCv(i,J) * yquad(qpoint) ! d(x)/d(x*) ! d = G%dyCu(I-1,j) * (1-xquad(qpoint)) + G%dyCu(I,j) * xquad(qpoint) ! d(y)/d(y*) @@ -2884,10 +2890,10 @@ end subroutine bilinear_shape_fn_grid subroutine bilinear_shape_functions_subgrid(Phisub, nsub) + integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction real, dimension(nsub,nsub,2,2,2,2), & intent(inout) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] - integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction ! this subroutine is a helper for interpolation of floatation condition ! for the purposes of evaluating the terms \int (u,v) \phi_i dx dy in a cell that is @@ -2912,9 +2918,9 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! | | ! 1 - 2 - integer :: i, j, k, l, qx, qy, indx, indy + integer :: i, j, qx, qy real,dimension(2) :: xquad - real :: x0, y0, x, y, val, fracx + real :: x0, y0, x, y, fracx xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) fracx = 1.0/real(nsub) @@ -3250,16 +3256,13 @@ subroutine ice_shelf_advect_temp_x(CS, G, time_step, hmask, h0, h_after_uflux) ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_east_bdry, at_west_bdry, one_off_west_bdry, one_off_east_bdry + logical :: at_east_bdry, at_west_bdry real, dimension(-2:2) :: stencil real :: u_face ! Zonal velocity at a face, positive if out {L T-1 ~> m s-1] real :: flux_diff, phi - character (len=1) :: debug_str - - is = G%isc-2 ; ie = G%iec+2 ; js = G%jsc ; je = G%jec ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset @@ -3420,13 +3423,12 @@ subroutine ice_shelf_advect_temp_y(CS, G, time_step, hmask, h_after_uflux, h_aft ! use will be made of ISS%hmask here - its value at the boundary will be zero, just like uncovered cells ! if there is an input bdry condition, the thickness there will be set in initialization - integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, gjed, gied + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed integer :: i_off, j_off - logical :: at_north_bdry, at_south_bdry, one_off_west_bdry, one_off_east_bdry + logical :: at_north_bdry, at_south_bdry real, dimension(-2:2) :: stencil real :: v_face ! Pseudo-meridional velocity at a cell face, positive if out {L T-1 ~> m s-1] real :: flux_diff, phi - character(len=1) :: debug_str is = G%isc ; ie = G%iec ; js = G%jsc-1 ; je = G%jec+1 ; isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed i_off = G%idg_offset ; j_off = G%jdg_offset diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 7cc3c020a3..77d1cc8a3a 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -45,7 +45,6 @@ subroutine initialize_ice_thickness(h_shelf, area_shelf_h, hmask, G, G_in, US, P logical, intent(in), optional :: rotate_index !< If true, this is a rotation test integer, intent(in), optional :: turns !< Number of turns for rotation test - integer :: i, j character(len=40) :: mdl = "initialize_ice_thickness" ! This subroutine's name. character(len=200) :: config logical :: rotate = .false. @@ -105,7 +104,7 @@ subroutine initialize_ice_thickness_from_file(h_shelf, area_shelf_h, hmask, G, U character(len=40) :: mdl = "initialize_ice_thickness_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec logical :: hmask_set - real :: len_sidestress, mask, udh + real :: len_sidestress, udh call MOM_mesg("Initialize_ice_thickness_from_file: reading thickness") @@ -196,7 +195,7 @@ subroutine initialize_ice_thickness_channel(h_shelf, area_shelf_h, hmask, G, US, character(len=40) :: mdl = "initialize_ice_shelf_thickness_channel" ! This subroutine's name. real :: max_draft, min_draft, flat_shelf_width, c1, slope_pos - real :: edge_pos, shelf_slope_scale, Rho_ocean + real :: edge_pos, shelf_slope_scale integer :: i, j, jsc, jec, jsd, jed, jedg, nyh, isc, iec, isd, ied integer :: j_off @@ -277,145 +276,136 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b thickness_bdry_val, hmask, h_shelf, G,& US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces - - real, dimension(SZIB_(G),SZJ_(G)), & - intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through - !! C-grid u faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces - - real, dimension(SZI_(G),SZJB_(G)), & - intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through - !! C-grid v faces [L Z T-1 ~> m2 s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_shelf !< Ice-shelf thickness - 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 - - character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. - integer :: i, j, isd, jsd, is, js, iegq, jegq, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed - real :: input_thick ! The input ice shelf thickness [Z ~> m] - real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] - real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - - - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & - "inflow ice velocity at upstream boundary", & - units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) - call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & - "flux thickness at upstream boundary", & - units="m", default=1000., scale=US%m_to_Z) - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & - "maximum position of no-flow condition in along-flow direction", & - units="km", default=0.) - - call MOM_mesg(mdl//": setting boundary") - - isd = G%isd ; ied = G%ied - jsd = G%jsd ; jed = G%jed - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal - gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo - giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc - - !---------b.c.s based on geopositions ----------------- - do j=jsc,jec+1 - do i=isc-1,iec+1 - ! upstream boundary - set either dirichlet or flux condition - - if (G%geoLonBu(i,j) == westlon) then - hmask(i+1,j) = 3.0 - h_bdry_val(i+1,j) = h_shelf(i+1,j) - thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) - u_face_mask_bdry(i+1,j) = 3.0 - u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution - endif - - - ! side boundaries: no flow - if (G%geoLatBu(i,j-1) == southlat) then !bot boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j+1) = 0. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - else - v_face_mask_bdry(i,j+1) = 1. - u_face_mask_bdry(i,j) = 3. - u_bdry_val(i,j) = 0. - v_bdry_val(i,j) = 0. - endif - elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary - if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then - v_face_mask_bdry(i,j-1) = 0. - u_face_mask_bdry(i,j-1) = 3. - else - v_face_mask_bdry(i,j-1) = 3. - u_face_mask_bdry(i,j-1) = 3. - endif - endif - - ! downstream boundary - CFBC - if (G%geoLonBu(i,j) == westlon+lenlon) then - u_face_mask_bdry(i-1,j) = 2.0 - endif - - enddo - enddo + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at C-grid u faces + + real, dimension(SZIB_(G),SZJ_(G)), & + intent(inout) :: u_flux_bdry_val !< The boundary thickness flux through + !! C-grid u faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at C-grid v faces + + real, dimension(SZI_(G),SZJB_(G)), & + intent(inout) :: v_flux_bdry_val !< The boundary thickness flux through + !! C-grid v faces [L Z T-1 ~> m2 s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_shelf !< Ice-shelf thickness [Z ~> m] + 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 + + character(len=40) :: mdl = "initialize_ice_shelf_boundary_channel" ! This subroutine's name. + integer :: i, j, isd, jsd, giec, gjec, gisc, gjsc,gisd,gjsd, isc, jsc, iec, jec, ied, jed + real :: input_thick ! The input ice shelf thickness [Z ~> m] + real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] + real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises + + call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) + + call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) + + call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & + "inflow ice velocity at upstream boundary", & + units="m s-1", default=0., scale=US%m_s_to_L_T*US%m_to_Z) !### This conversion factor is wrong? + call get_param(PF, mdl, "INPUT_THICK_ICE_SHELF", input_thick, & + "flux thickness at upstream boundary", & + units="m", default=1000., scale=US%m_to_Z) + call get_param(PF, mdl, "LEN_SIDE_STRESS", len_stress, & + "maximum position of no-flow condition in along-flow direction", & + units="km", default=0.) + + call MOM_mesg(mdl//": setting boundary") + + isd = G%isd ; ied = G%ied + jsd = G%jsd ; jed = G%jed + isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + gjsd = G%Domain%njglobal ; gisd = G%Domain%niglobal + gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo + giec = G%Domain%niglobal+gisc ; gjec = G%Domain%njglobal+gjsc + + !---------b.c.s based on geopositions ----------------- + do j=jsc,jec+1 + do i=isc-1,iec+1 + ! upstream boundary - set either dirichlet or flux condition + + if (G%geoLonBu(i,j) == westlon) then + hmask(i+1,j) = 3.0 + h_bdry_val(i+1,j) = h_shelf(i+1,j) + thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + u_face_mask_bdry(i+1,j) = 3.0 + u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution + endif + + + ! side boundaries: no flow + if (G%geoLatBu(i,j-1) == southlat) then !bot boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j+1) = 0. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + else + v_face_mask_bdry(i,j+1) = 1. + u_face_mask_bdry(i,j) = 3. + u_bdry_val(i,j) = 0. + v_bdry_val(i,j) = 0. + endif + elseif (G%geoLatBu(i,j-1) == southlat+lenlat) then !top boundary + if (len_stress == 0. .OR. G%geoLonCv(i,j) <= len_stress) then + v_face_mask_bdry(i,j-1) = 0. + u_face_mask_bdry(i,j-1) = 3. + else + v_face_mask_bdry(i,j-1) = 3. + u_face_mask_bdry(i,j-1) = 3. + endif + endif + + ! downstream boundary - CFBC + if (G%geoLonBu(i,j) == westlon+lenlon) then + u_face_mask_bdry(i-1,j) = 2.0 + endif + + enddo + enddo end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file -!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& -! hmask,h_shelf, G, US, PF) subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf -! real, dimension(SZDI_(G),SZDJ_(G)), & -! intent(in) :: h_shelf !< A mask indicating which tracer points are -! !! partly or fully covered by an ice-shelf + !! shelf is floating: 0 if floating, 1 if not. [nondim] 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 @@ -425,8 +415,7 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& character(len=200) :: ushelf_varname, vshelf_varname, & ice_visc_varname, floatfr_varname, bed_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. - integer :: i, j, isc, jsc, iec, jec - real :: len_sidestress, mask, udh + real :: len_sidestress call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") @@ -461,14 +450,14 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& floatfr_varname = "float_frac" - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vshelf_varname), v_shelf, G%Domain, position=CORNER,scale=1.0) -! call MOM_read_data(filename,trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(floatfr_varname), float_cond, G%Domain, scale=1.) + !### I think that the following two lines should have ..., scale=US%m_s_to_L_T + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=1.0) +! call MOM_read_data(filename, trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) + call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) - filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) -! isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec + filename = trim(inputdir)//trim(bed_topo_file) + call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) end subroutine initialize_ice_flow_from_file @@ -478,37 +467,38 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & hmask, h_shelf, G, US, PF ) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZIB_(G),SZJB_(G)), & - intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: umask !< A mask foor ice shelf velocity - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: vmask !< A mask foor ice shelf velocity - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: hmask !< A mask indicating which tracer points are - !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: h_shelf !< Ice-shelf thickness - 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 + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_face_mask_bdry !< A boundary-type mask at B-grid u faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_face_mask_bdry !< A boundary-type mask at B-grid v faces [nondim] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: u_bdry_val !< The zonal ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJB_(G)), & + intent(inout) :: v_bdry_val !< The meridional ice shelf velocity at open + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: umask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDIB_(G),SZDJB_(G)), & + intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + !! boundary vertices [L T-1 ~> m s-1]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: hmask !< A mask indicating which tracer points are + !! partly or fully covered by an ice-shelf [nondim] + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf !< Ice-shelf thickness [Z ~> m] + 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 character(len=200) :: filename, bc_file, inputdir, icethick_file ! Strings for file/path character(len=200) :: ufcmskbdry_varname, vfcmskbdry_varname, & ubdryv_varname, vbdryv_varname, umask_varname, vmask_varname, & - h_varname,hmsk_varname ! Variable name in file + hmsk_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_shelf_boundary_from_file" ! This subroutine's name. integer :: i, j, isc, jsc, iec, jec @@ -526,9 +516,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call get_param(PF, mdl, "ICE_THICKNESS_FILE", icethick_file, & "The file from which the ice-shelf thickness is read.", & default="ice_shelf_thick.nc") -! call get_param(PF, mdl, "ICE_THICKNESS_VARNAME", h_varname, & -! "The name of the thickness variable in ICE_THICKNESS_FILE.", & -! default="h_shelf") call get_param(PF, mdl, "ICE_THICKNESS_MASK_VARNAME", hmsk_varname, & "The name of the icethickness mask variable in ICE_THICKNESS_FILE.", & default="h_mask") @@ -557,24 +544,24 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, trim(ufcmskbdry_varname),u_face_mask_bdry, G%Domain,position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER,scale=1.0) - call MOM_read_data(filename,trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(umask_varname), umask, G%Domain, position=CORNER,scale=1.) - call MOM_read_data(filename,trim(vmask_varname), vmask, G%Domain, position=CORNER,scale=1.) - filename = trim(inputdir)//trim(icethick_file) + call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) + !### I think that the following two lines should have ..., scale=US%m_s_to_L_T + call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=1.0) + call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(vmask_varname), vmask, G%Domain, position=CORNER, scale=1.) + filename = trim(inputdir)//trim(icethick_file) -! call MOM_read_data(filename, trim(h_varname), h_shelf, G%Domain, scale=US%m_to_Z) - call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) + call MOM_read_data(filename,trim(hmsk_varname), hmask, G%Domain, scale=1.) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec do j=jsc,jec do i=isc,iec - if (hmask(i,j) == 3.) then - thickness_bdry_val(i,j) = h_shelf(i,j) - h_bdry_val(i,j) = h_shelf(i,j) - endif + if (hmask(i,j) == 3.) then + thickness_bdry_val(i,j) = h_shelf(i,j) + h_bdry_val(i,j) = h_shelf(i,j) + endif enddo enddo @@ -583,8 +570,8 @@ end subroutine initialize_ice_shelf_boundary_from_file !> Initialize ice basal friction subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: C_basal_friction !< Ice-stream basal friction + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: C_basal_friction !< Ice-stream basal friction 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 @@ -604,19 +591,19 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) - C_basal_friction(:,:) = C_friction + C_basal_friction(:,:) = C_friction elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading friction coefficients") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & - "The file from which basal friction coefficients are read.", & - default="ice_basal_friction.nc") - filename = trim(inputdir)//trim(C_friction_file) - call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) + call get_param(PF, mdl, "BASAL_FRICTION_FILE", C_friction_file, & + "The file from which basal friction coefficients are read.", & + default="ice_basal_friction.nc") + filename = trim(inputdir)//trim(C_friction_file) + call log_param(PF, mdl, "INPUTDIR/BASAL_FRICTION_FILE", filename) - call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & + call get_param(PF, mdl, "BASAL_FRICTION_VARNAME", varname, & "The variable to use in basal traction.", & default="tau_b_beta") @@ -632,8 +619,8 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) !> Initialize ice basal friction subroutine initialize_ice_AGlen(AGlen, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen 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 @@ -653,19 +640,19 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call get_param(PF, mdl, "A_GLEN", A_Glen, & "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) - AGlen(:,:) = A_Glen + AGlen(:,:) = A_Glen elseif (trim(config)=="FILE") then - call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") - call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") - inputdir = slasher(inputdir) + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading ice-stiffness parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) - call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & + call get_param(PF, mdl, "ICE_STIFFNESS_FILE", AGlen_file, & "The file from which the ice-stiffness is read.", & default="ice_AGlen.nc") - filename = trim(inputdir)//trim(AGlen_file) - call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) - call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & + filename = trim(inputdir)//trim(AGlen_file) + call log_param(PF, mdl, "INPUTDIR/ICE_STIFFNESS_FILE", filename) + call get_param(PF, mdl, "A_GLEN_VARNAME", varname, & "The variable to use as ice-stiffness.", & default="A_GLEN") diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 64d4dbfdab..f24f9b1881 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -176,8 +176,9 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) type(param_file_type), intent(in) :: param_file !< Runtime parameter handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice -! This include declares and sets the variable "version". -#include "version_variable.h" + + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_marine_ice" ! This module's name. if (associated(CS)) then @@ -197,8 +198,8 @@ subroutine marine_ice_init(Time, G, param_file, diag, CS) "The latent heat of fusion.", units="J/kg", default=hlf, scale=G%US%J_kg_to_Q) call get_param(param_file, mdl, "BERG_AREA_THRESHOLD", CS%berg_area_threshold, & "Fraction of grid cell which iceberg must occupy, so that fluxes "//& - "below berg are set to zero. Not applied for negative "//& - "values.", units="non-dim", default=-1.0) + "below berg are set to zero. Not applied for negative values.", & + units="nondim", default=-1.0) end subroutine marine_ice_init diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 9635f51262..efeb7d7f8e 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -57,12 +57,7 @@ subroutine USER_initialize_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, !! being started from a restart file. ! This subroutine sets up the initial mass and area covered by the ice shelf. - real :: max_draft ! The maximum ocean draft of the ice shelf [Z ~> m]. - real :: min_draft ! The minimum ocean draft of the ice shelf [Z ~> m]. - real :: flat_shelf_width ! The range over which the shelf is min_draft thick. - real :: c1 ! The maximum depths in m. character(len=40) :: mdl = "USER_initialize_shelf_mass" ! This subroutine's name. - integer :: i, j ! call MOM_error(FATAL, "USER_shelf_init.F90, USER_set_shelf_mass: " // & ! "Unmodified user routine called - you must edit the routine to use it") diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 286dfa7d95..310a7f9392 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -9,8 +9,7 @@ module MOM_coord_initialization use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, read_param, log_param, param_file_type, log_version use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists -use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc -use MOM_io, only : SINGLE_FILE, MULTIPLE +use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE use MOM_string_functions, only : slasher, uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -20,7 +19,7 @@ module MOM_coord_initialization implicit none ; private -public MOM_initialize_coord +public MOM_initialize_coord, write_vertgrid_file ! 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 @@ -33,13 +32,11 @@ module MOM_coord_initialization !> MOM_initialize_coord sets up time-invariant quantities related to MOM6's !! vertical coordinate. -subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_depth) +subroutine MOM_initialize_coord(GV, US, PF, tv, max_depth) type(verticalGrid_type), intent(inout) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - logical, intent(in) :: write_geom !< If true, write grid geometry files. - character(len=*), intent(in) :: output_dir !< The directory into which to write files. type(thermo_var_ptrs), intent(inout) :: tv !< The thermodynamic variable structure. real, intent(in) :: max_depth !< The ocean's maximum depth [Z ~> m]. ! Local @@ -107,12 +104,9 @@ subroutine MOM_initialize_coord(GV, US, PF, write_geom, output_dir, tv, max_dept if (debug) call chksum(US%m_to_Z*US%L_to_m**2*US%s_to_T**2*GV%g_prime(:), "MOM_initialize_coord: g_prime ", 1, nz) call setVerticalGridAxes( GV%Rlay, GV, scale=US%R_to_kg_m3 ) -! Copy the maximum depth across from the input argument + ! Copy the maximum depth across from the input argument GV%max_depth = max_depth -! Write out all of the grid data used by this run. - if (write_geom) call write_vertgrid_file(GV, US, PF, output_dir) - call callTree_leave('MOM_initialize_coord()') end subroutine MOM_initialize_coord @@ -318,7 +312,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] integer :: k, nz, k_light character(len=40) :: mdl = "set_coord_from_TS_range" ! This subroutine's name. - character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + nz = GV%ke call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 498e1915ba..09814403a4 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -172,10 +172,6 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: tempH1, tempH2, tempH3, tempH4 - real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: tempQ1, tempQ2, tempQ3, tempQ4 - real, dimension(G%IsdB:G%IedB,G%jsd :G%jed ) :: tempE1, tempE2 - real, dimension(G%isd :G%ied ,G%JsdB:G%JedB) :: tempN1, tempN2 ! These arrays are a holdover from earlier code in which the arrays in G were ! macros and may have had reduced dimensions. real, dimension(G%isd :G%ied ,G%jsd :G%jed ) :: dxT, dyT, areaT @@ -527,7 +523,7 @@ subroutine set_grid_metrics_spherical(G, param_file, US) integer :: i_offset, j_offset real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) - real :: dLon,dLat,latitude,longitude,dL_di + real :: dLon, dLat, latitude, dL_di character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_spherical" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -661,7 +657,6 @@ subroutine set_grid_metrics_mercator(G, param_file, US) integer :: i, j, isd, ied, jsd, jed integer :: I_off, J_off type(GPS) :: GP - character(len=128) :: warnmesg character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" real :: PI, PI_2! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 real :: y_q, y_h, jd, x_q, x_h, id @@ -677,7 +672,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) ! Int_dj_dy at a latitude or longitude that is real :: jRef, iRef ! being set to be at grid index jRef or iRef. integer :: itt1, itt2 - logical :: debug = .FALSE., simple_area = .true. + logical, parameter :: simple_area = .true. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB ! All of the metric terms should be defined over the domain from diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index fc5ceaf3e4..52f47f9581 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -184,7 +184,7 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(:), allocatable :: new_depth ! The new values of the depths [m] + real, dimension(:), allocatable :: new_depth ! The new values of the depths [Z ~> m] integer, dimension(:), allocatable :: ig, jg ! The global indicies of the points to modify character(len=200) :: topo_edits_file, inputdir ! Strings for file/path character(len=40) :: mdl = "apply_topography_edits_from_file" ! This subroutine's name. @@ -247,22 +247,22 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) ! Read iEdit, jEdit and zEdit call read_variable(topo_edits_file, 'iEdit', ig, ncid_in=ncid) call read_variable(topo_edits_file, 'jEdit', jg, ncid_in=ncid) - call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid) + call read_variable(topo_edits_file, 'zEdit', new_depth, ncid_in=ncid, scale=US%m_to_Z) call close_file_to_read(ncid, topo_edits_file) do n = 1, n_edits i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 j = jg(n) - G%jsd_global + 2 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then - if (new_depth(n)*US%m_to_Z /= mask_depth) then + if (new_depth(n) /= mask_depth) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(new_depth(n)), i, j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ', n, ig(n), jg(n), D(i,j)*US%Z_to_m, '->', abs(US%Z_to_m*new_depth(n)), i, j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else if (topo_edits_change_mask) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & - 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(new_depth(n)),i,j - D(i,j) = abs(US%m_to_Z*new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) + 'Ocean topography edit: ',n,ig(n),jg(n),D(i,j)*US%Z_to_m,'->',abs(US%Z_to_m*new_depth(n)),i,j + D(i,j) = abs(new_depth(n)) ! Allows for height-file edits (i.e. converts negatives) else call MOM_error(FATAL, ' apply_topography_edits_from_file: '//& "A zero depth edit would change the land mask and is not allowed in"//trim(topo_edits_file)) @@ -454,8 +454,8 @@ subroutine set_rotation_planetary(f, G, param_file, US) call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") call get_param(param_file, "set_rotation_planetary", "OMEGA", omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) PI = 4.0*atan(1.0) do I=G%IsdB,G%IedB ; do J=G%JsdB,G%JedB @@ -802,7 +802,7 @@ subroutine reset_face_lengths_list(G, param_file, US) ! Local variables character(len=120), pointer, dimension(:) :: lines => NULL() character(len=120) :: line - character(len=200) :: filename, chan_file, inputdir, mesg ! Strings for file/path + character(len=200) :: filename, chan_file, inputdir ! Strings for file/path character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. real, allocatable, dimension(:,:) :: & u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees] @@ -826,7 +826,7 @@ subroutine reset_face_lengths_list(G, param_file, US) logical :: fatal_unused_lengths integer :: unused integer :: ios, iounit, isu, isv - integer :: last, num_lines, nl_read, ln, npt, u_pt, v_pt + integer :: num_lines, nl_read, ln, npt, u_pt, v_pt integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isu_por, isv_por logical :: found_u_por, found_v_por @@ -893,13 +893,13 @@ subroutine reset_face_lengths_list(G, param_file, US) allocate(v_line_used(num_lines), source=0) allocate(v_line_no(num_lines), source=0) - allocate(Dmin_u(num_lines)) ; Dmin_u(:) = 0.0 - allocate(Dmax_u(num_lines)) ; Dmax_u(:) = 0.0 - allocate(Davg_u(num_lines)) ; Davg_u(:) = 0.0 + allocate(Dmin_u(num_lines), source=0.0) + allocate(Dmax_u(num_lines), source=0.0) + allocate(Davg_u(num_lines), source=0.0) - allocate(Dmin_v(num_lines)) ; Dmin_v(:) = 0.0 - allocate(Dmax_v(num_lines)) ; Dmax_v(:) = 0.0 - allocate(Davg_v(num_lines)) ; Davg_v(:) = 0.0 + allocate(Dmin_v(num_lines), source=0.0) + allocate(Dmax_v(num_lines), source=0.0) + allocate(Davg_v(num_lines), source=0.0) ! Actually read the lines. if (is_root_pe()) then @@ -1124,7 +1124,7 @@ subroutine read_face_length_list(iounit, filename, num_lines, lines) ! list file, after removing comments. character(len=120) :: line, line_up logical :: found_u, found_v - integer :: isu, isv, icom, verbose + integer :: isu, isv, icom integer :: last num_lines = 0 diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 37ad482a5b..ae7a23c3c9 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -20,7 +20,7 @@ module MOM_state_initialization use MOM_interface_heights, only : find_eta use MOM_io, only : file_exists, field_size, MOM_read_data, MOM_read_vector, slasher use MOM_open_boundary, only : ocean_OBC_type, open_boundary_init, set_tracer_data -use MOM_open_boundary, only : OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : OBC_NONE use MOM_open_boundary, only : open_boundary_query use MOM_open_boundary, only : set_tracer_data, initialize_segment_data use MOM_open_boundary, only : open_boundary_test_extern_h @@ -88,12 +88,10 @@ module MOM_state_initialization use dumbbell_initialization, only : dumbbell_initialize_sponges use MOM_tracer_Z_init, only : tracer_Z_init_array, determine_temperature use MOM_ALE, only : ALE_initRegridding, ALE_CS, ALE_initThicknessToCoord -use MOM_ALE, only : ALE_remap_scalar, ALE_build_grid, ALE_regrid_accelerated -use MOM_ALE, only : TS_PLM_edge_values +use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution -use MOM_regridding, only : regridding_main -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h +use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd use MOM_oda_incupd, only: set_up_oda_incupd_field, set_up_oda_incupd_vel_field @@ -153,8 +151,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !! ice shelf [ R Z ~> kg m-2 ] ! Local variables real :: depth_tot(SZI_(G),SZJ_(G)) ! The nominal total depth of the ocean [Z ~> m] - character(len=200) :: filename ! The name of an input file. - character(len=200) :: filename2 ! The name of an input files. character(len=200) :: inputdir ! The directory where NetCDF input files are. character(len=200) :: config real :: H_rescale ! A rescaling factor for thicknesses from the representation in @@ -165,7 +161,6 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & logical :: from_Z_file, useALE logical :: new_sim - integer :: write_geom logical :: use_temperature, use_sponge, use_OBC, use_oda_incupd logical :: verify_restart_time logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -212,7 +207,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & use_EOS = associated(tv%eqn_of_state) use_OBC = associated(OBC) if (use_EOS) eos => tv%eqn_of_state - use_ice_shelf=PRESENT(frac_shelf_h) + use_ice_shelf = PRESENT(frac_shelf_h) !==================================================================== ! Initialize temporally evolving fields, either as initial @@ -533,13 +528,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "MOM6 attempted to restart from a file from a different time than given by Time_in.") Time = Time_in endif - if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + if ((GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do k=1,nz ; do j=js,je ; do i=is,ie ; h(i,j,k) = H_rescale * h(i,j,k) ; enddo ; enddo ; enddo endif if ( (US%s_to_T_restart * US%m_to_L_restart /= 0.0) .and. & - ((US%m_to_L * US%s_to_T_restart) /= (US%m_to_L_restart * US%s_to_T)) ) then - vel_rescale = (US%m_to_L * US%s_to_T_restart) / (US%m_to_L_restart * US%s_to_T) + (US%s_to_T_restart /= US%m_to_L_restart) ) then + vel_rescale = US%s_to_T_restart / US%m_to_L_restart do k=1,nz ; do j=jsd,jed ; do I=IsdB,IeDB ; u(I,j,k) = vel_rescale * u(I,j,k) ; enddo ; enddo ; enddo do k=1,nz ; do J=JsdB,JedB ; do i=isd,ied ; v(i,J,k) = vel_rescale * v(i,J,k) ; enddo ; enddo ; enddo endif @@ -691,6 +686,8 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. integer :: inconsistent = 0 logical :: correct_thickness + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path integer :: i, j, k, is, ie, js, je, nz @@ -721,12 +718,18 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(param_file, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif if (just_read) return ! All run-time parameters have been read, so return. call MOM_read_data(filename, "eta", eta(:,:,:), G%Domain, scale=US%m_to_Z) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, eta, h, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (eta(i,j,K) < (eta(i,j,K+1) + GV%Angstrom_Z)) then @@ -760,31 +763,29 @@ end subroutine initialize_thickness_from_file !! layers are contracted to ANGSTROM thickness (which may be 0). !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. -!! @remark{There is a (hard-wired) "tolerance" parameter such that the -!! criteria for adjustment must equal or exceed 10cm.} -subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) +subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, ht, dZ_ref_eta) 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(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: eta !< Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, intent(in) :: ht !< Tolerance to exceed adjustment + !! criteria [Z ~> m] real, optional, intent(in) :: dZ_ref_eta !< The difference between the !! reference heights for bathyT and !! eta [Z ~> m], 0 by default. ! Local variables integer :: i, j, k, is, ie, js, je, nz, contractions, dilations - real :: hTolerance = 0.1 !< Tolerance to exceed adjustment criteria [Z ~> m] real :: dilate ! A factor by which the column is dilated [nondim] real :: dZ_ref ! The difference in the reference heights for G%bathyT and eta [Z ~> m] character(len=100) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - hTolerance = 0.1*US%m_to_Z dZ_ref = 0.0 ; if (present(dZ_ref_eta)) dZ_ref = dZ_ref_eta contractions = 0 do j=js,je ; do i=is,ie - if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + hTolerance) then + if (-eta(i,j,nz+1) > (G%bathyT(i,j) + dZ_ref) + ht) then eta(i,j,nz+1) = -(G%bathyT(i,j) + dZ_ref) contractions = contractions + 1 endif @@ -814,7 +815,7 @@ subroutine adjustEtaToFitBathymetry(G, GV, US, eta, h, dZ_ref_eta) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. ! This should be... if ((G%mask2dt(i,j)*(eta(i,j,1)-eta(i,j,nz+1)) > 0.0) .and. & - if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - hTolerance) then + if (-eta(i,j,nz+1) < (G%bathyT(i,j) + dZ_ref) - ht) then dilations = dilations + 1 if (eta(i,j,1) <= eta(i,j,nz+1)) then do k=1,nz ; h(i,j,k) = (eta(i,j,1) + (G%bathyT(i,j) + dZ_ref)) / real(nz) ; enddo @@ -1173,7 +1174,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(PF, mdl, "SURFACE_PRESSURE_VAR", p_surf_var, & "The initial condition variable for the surface pressure exerted by ice.", & - units="Pa", default="", do_not_log=just_read) + default="", do_not_log=just_read) call get_param(PF, mdl, "INPUTDIR", inputdir, default=".", do_not_log=.true.) filename = trim(slasher(inputdir))//trim(p_surf_file) if (.not.just_read) call log_param(PF, mdl, "!INPUTDIR/SURFACE_HEIGHT_IC_FILE", filename) @@ -1788,10 +1789,10 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read) !! without changing T or S. integer :: k - real :: delta_S, delta_T real :: S_top, T_top ! Reference salinity and temperature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical - real :: delta + !real :: delta_S, delta_T + !real :: delta character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's name. if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") @@ -1811,24 +1812,24 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. ! Prescribe salinity -! delta_S = S_range / ( GV%ke - 1.0 ) -! S(:,:,1) = S_top -! do k=2,GV%ke -! S(:,:,k) = S(:,:,k-1) + delta_S -! enddo + !delta_S = S_range / ( GV%ke - 1.0 ) + !S(:,:,1) = S_top + !do k=2,GV%ke + ! S(:,:,k) = S(:,:,k-1) + delta_S + !enddo do k=1,GV%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(GV%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(GV%ke)) enddo ! Prescribe temperature -! delta_T = T_range / ( GV%ke - 1.0 ) -! T(:,:,1) = T_top -! do k=2,GV%ke -! T(:,:,k) = T(:,:,k-1) + delta_T -! enddo -! delta = 1 -! T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 + !delta_T = T_range / ( GV%ke - 1.0 ) + !T(:,:,1) = T_top + !do k=2,GV%ke + ! T(:,:,k) = T(:,:,k-1) + delta_T + !enddo + !delta = 1 + !T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -1889,10 +1890,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t character(len=200) :: filename, inputdir ! Strings for file/path and path. logical :: use_ALE ! True if ALE is being used, False if in layered mode - logical :: time_space_interp_sponge ! True if using sponge data which - ! need to be interpolated from in both the horizontal dimension and in - ! time prior to vertical remapping. - + logical :: new_sponge_param ! The value of a deprecated parameter. + logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both + ! the horizontal dimension and in time prior to vertical remapping. 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 @@ -1944,21 +1944,35 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t "The name of the inverse damping rate variable in "//& "SPONGE_UV_DAMPING_FILE for the velocities.", default=Idamp_var) endif - call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) - time_space_interp_sponge = .false. - call get_param(param_file, mdl, "NEW_SPONGES", time_space_interp_sponge, & + call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) + + !### NEW_SPONGES should be obsoleted properly, rather than merely deprecated, at which + ! point only the else branch of the new_sponge_param block would be retained. + call get_param(param_file, mdl, "NEW_SPONGES", new_sponge_param, & "Set True if using the newer sponging code which "//& "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=.false.) - if (time_space_interp_sponge) then - call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& + "of sponge restoring data.", default=.false., do_not_log=.true.) + if (new_sponge_param) then + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.true., do_not_log=.true.) + if (.not.time_space_interp_sponge) then + call MOM_error(FATAL, " initialize_sponges: NEW_SPONGES has been deprecated, "//& + "but is set to true inconsistently with INTERPOLATE_SPONGE_TIME_SPACE. "//& + "Remove the NEW_SPONGES input line.") + else + call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& "INTERPOLATE_SPONGE_TIME_SPACE = True.") + endif + call log_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.true.) + else + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & + default=.false.) endif - call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & - "Set True if using the newer sponging code which "//& - "performs on-the-fly regridding in lat-lon-time.",& - "of sponge restoring data.", default=time_space_interp_sponge) ! Read in sponge damping rate for tracers @@ -1983,18 +1997,18 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t call MOM_read_vector(filename, Idamp_u_var,Idamp_v_var,Idamp_u(:,:),Idamp_v(:,:), G%Domain, scale=US%T_to_s) else - ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") - call pass_var(Idamp,G%Domain) - do j=G%jsc,G%jec - do i=G%iscB,G%iecB - Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) - enddo - enddo - do j=G%jscB,G%jecB - do i=G%isc,G%iec - Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) - enddo - enddo + ! call MOM_error(FATAL, "Must provide SPONGE_IDAMP_U_var and SPONGE_IDAMP_V_var") + call pass_var(Idamp,G%Domain) + do j=G%jsc,G%jec + do i=G%iscB,G%iecB + Idamp_u(I,j) = 0.5*(Idamp(i,j)+Idamp(i+1,j)) + enddo + enddo + do j=G%jscB,G%jecB + do i=G%isc,G%iec + Idamp_v(i,J) = 0.5*(Idamp(i,j)+Idamp(i,j+1)) + enddo + enddo endif endif @@ -2175,7 +2189,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda fields real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading oda fields - integer :: i, j, k, is, ie, js, je, nz + integer :: is, ie, js, je, nz integer :: isd, ied, jsd, jed integer, dimension(4) :: siz @@ -2238,7 +2252,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p "The name of the meridional vel. inc. variable in "//& "ODA_INCUPD_FILE.", default="v_inc") -! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log = .true.) +! call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, do_not_log=.true.) ! Read in incremental update for tracers filename = trim(inputdir)//trim(inc_file) @@ -2375,9 +2389,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just !! and salinity in z-space; by default it is also used for ice shelf area. character(len=200) :: tfilename !< The name of an input file containing temperature in z-space. character(len=200) :: sfilename !< The name of an input file containing salinity in z-space. - character(len=200) :: shelf_file !< The name of an input file used for ice shelf area. character(len=200) :: inputdir !! The directory where NetCDF input files are. - character(len=200) :: mesg, area_varname, ice_shelf_file + character(len=200) :: mesg type(EOS_type), pointer :: eos => NULL() type(thermo_var_ptrs) :: tv_loc ! A temporary thermo_var container @@ -2388,11 +2401,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: is, ie, js, je, nz ! compute domain indices - integer :: isc,iec,jsc,jec ! global compute domain indices integer :: isg, ieg, jsg, jeg ! global extent integer :: isd, ied, jsd, jed ! data domain indices - integer :: i, j, k, ks, np, ni, nj + integer :: i, j, k, ks integer :: nkml ! The number of layers in the mixed layer. integer :: kd, inconsistent @@ -2402,34 +2414,36 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real :: PI_180 ! for conversion from degrees to radians real :: Hmix_default ! The default initial mixed layer depth [m]. real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. - real :: dilate ! A dilation factor to match topography [nondim] real :: missing_value_temp, missing_value_salt logical :: correct_thickness + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: potemp_var, salin_var - character(len=8) :: laynum integer, parameter :: niter=10 ! number of iterations for t/s adjustment to layer density logical :: adjust_temperature = .true. ! fit t/s to target densities real, parameter :: missing_value = -1.e20 real, parameter :: temp_land_fill = 0.0, salt_land_fill = 35.0 - logical :: reentrant_x, tripolar_n,dbg - logical :: debug = .false. ! manually set this to true for verbose output + logical :: reentrant_x, tripolar_n ! data arrays real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] - real, dimension(:,:,:), allocatable, target :: temp_z, salt_z, mask_z + real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [degC] + real, dimension(:,:,:), allocatable, target :: salt_z ! Input salinities [ppt] + real, dimension(:,:,:), allocatable, target :: mask_z ! 1 for valid data points [nondim] real, dimension(:,:,:), allocatable :: rho_z ! Densities in Z-space [R ~> kg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zi ! Interface heights [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: Z_bottom ! The (usually negative) height of the seafloor ! relative to the surface [Z ~> m]. - integer, dimension(SZI_(G),SZJ_(G)) :: nlevs + integer, dimension(SZI_(G),SZJ_(G)) :: nlevs ! The number of levels in each column with valid data real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping real, dimension(:), allocatable :: hTarget ! Target thicknesses [Z ~> m]. - real, dimension(:,:,:), allocatable, target :: tmpT1dIn, tmpS1dIn - real, dimension(:,:,:), allocatable :: tmp_mask_in + real, dimension(:,:,:), allocatable, target :: tmpT1dIn ! Input temperatures on a model-sized grid [degC] + real, dimension(:,:,:), allocatable, target :: tmpS1dIn ! Input salinities on a model-sized grid [ppt] + real, dimension(:,:,:), allocatable :: tmp_mask_in ! The valid data mask on a model-sized grid [nondim] real, dimension(:,:,:), allocatable :: h1 ! Thicknesses [H ~> m or kg m-2]. real, dimension(:,:,:), allocatable :: dz_interface ! Change in position of interface due to regridding real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. @@ -2438,17 +2452,18 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg logical :: answers_2018, default_2018_answers, hor_regrid_answers_2018 - logical :: use_ice_shelf logical :: pre_gridded logical :: separate_mixed_layer ! If true, handle the mixed layers differently. logical :: density_extrap_bug ! If true use an expression with a vertical indexing bug for ! extrapolating the densities at the bottom of unstable profiles ! from data when finding the initial interface locations in ! layered mode from a dataset of T and S. - character(len=10) :: remappingScheme - real :: tempAvg, saltAvg - integer :: nPoints, ans - integer :: id_clock_routine, id_clock_read, id_clock_interp, id_clock_fill, id_clock_ALE + character(len=64) :: remappingScheme + real :: tempAvg ! Spatially averaged temperatures on a layer [degC] + real :: saltAvg ! Spatially averaged salinities on a layer [ppt] + logical :: do_conv_adj, ignore + integer :: nPoints + integer :: id_clock_routine, id_clock_ALE id_clock_routine = cpu_clock_id('(Initialize from Z)', grain=CLOCK_ROUTINE) id_clock_ALE = cpu_clock_id('(Initialize from Z) ALE', grain=CLOCK_LOOP) @@ -2472,8 +2487,6 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - use_ice_shelf = present(frac_shelf_h) - call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE", filename, & "The name of the z-space input file used to initialize "//& "temperatures (T) and salinities (S). If T and S are not "//& @@ -2538,6 +2551,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) + if (correct_thickness) then + call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + "A parameter that controls the tolerance when adjusting the "//& + "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & + units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) + endif call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & "If true, all the interior layers are adjusted to "//& @@ -2695,11 +2714,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just GV_loc = GV GV_loc%ke = nkd allocate( dz_interface(isd:ied,jsd:jed,nkd+1) ) ! Need for argument to regridding_main() but is not used - if (use_ice_shelf) then - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, frac_shelf_h ) - else - call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface ) - endif + + call regridding_preadjust_reqs(regridCS, do_conv_adj, ignore) + if (do_conv_adj) call convective_adjustment(G, GV_loc, h1, tv_loc) + call regridding_main( remapCS, regridCS, G, GV_loc, h1, tv_loc, h, dz_interface, conv_adjust=.false., & + frac_shelf_h=frac_shelf_h ) + deallocate( dz_interface ) endif call ALE_remap_scalar(remapCS, G, GV, nkd, h1, tmpT1dIn, h, tv%T, all_cells=remap_full_column, & @@ -2735,7 +2755,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just Hmix_depth, eps_z, eps_rho, density_extrap_bug) if (correct_thickness) then - call adjustEtaToFitBathymetry(G, GV, US, zi, h, dZ_ref_eta=G%Z_ref) + call adjustEtaToFitBathymetry(G, GV, US, zi, h, h_tolerance, dZ_ref_eta=G%Z_ref) else do k=nz,1,-1 ; do j=js,je ; do i=is,ie if (zi(i,j,K) < (zi(i,j,K+1) + GV%Angstrom_Z)) then @@ -2764,7 +2784,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just do k=1,nz nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) >= 1.0) then + do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then nPoints = nPoints + 1 tempAvg = tempAvg + tv%T(i,j,k) saltAvg = saltAvg + tv%S(i,j,k) @@ -2772,6 +2792,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (homogenize) then + !### These averages will not reproduce across PE layouts or grid rotation. call sum_across_PEs(nPoints) call sum_across_PEs(tempAvg) call sum_across_PEs(saltAvg) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 8a67d71fe2..204a1e5f35 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -54,11 +54,9 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ !! This is not implemented yet. ! Local variables real :: land_fill = 0.0 - character(len=200) :: inputdir ! The directory where NetCDF input files are. - character(len=200) :: mesg real :: convert integer :: recnum - character(len=10) :: remapScheme + character(len=64) :: remapScheme logical :: homog,useALE ! This include declares and sets the variable "version". diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index f183231c88..a1894eb13f 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -134,6 +134,9 @@ module MOM_oda_driver_mod type(INC_CS) :: INC_CS !< A Structure containing integer file handles for bias adjustment integer :: id_inc_t !< A diagnostic handle for the temperature climatological adjustment integer :: id_inc_s !< A diagnostic handle for the salinity climatological adjustment + logical :: answers_2018 !< If true, use the order of arithmetic and expressions for remapping + !! that recover the answers from the end of 2018. Otherwise, use more + !! robust and accurate forms of mathematically equivalent expressions. end type ODA_CS @@ -161,24 +164,17 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) type(directories) :: dirs type(grid_type), pointer :: T_grid !< global tracer grid - real, dimension(:,:), allocatable :: global2D, global2D_old - real, dimension(:), allocatable :: lon1D, lat1D, glon1D, glat1D type(param_file_type) :: PF - integer :: n, m, k, i, j, nk - integer :: is,ie,js,je,isd,ied,jsd,jed - integer :: isg,ieg,jsg,jeg - integer :: idg_offset, jdg_offset - integer :: stdout_unit + integer :: n + integer :: isd, ied, jsd, jed integer, dimension(4) :: fld_sz character(len=32) :: assim_method - integer :: npes_pm, ens_info(6), ni, nj - character(len=128) :: mesg - character(len=32) :: fldnam + integer :: npes_pm, ens_info(6) character(len=30) :: coord_mode character(len=200) :: inputdir, basin_file - logical :: reentrant_x, reentrant_y, tripolar_N, symmetric character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file + logical :: default_2018_answers if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -235,6 +231,14 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default="PPM_H4") + call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & + "This sets the default value for the various _2018_ANSWERS parameters.", & + default=.false., do_not_log=.true.) + call get_param(PF, mdl, "ODA_2018_ANSWERS", CS%answers_2018, & + "If true, use the order of arithmetic and expressions that recover the "//& + "answers from original version of the ODA driver. Otherwise, use updated and "//& + "more robust forms of the same expressions.", default=default_2018_answers, & + do_not_log=.true.) inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) @@ -280,8 +284,7 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call clone_MOM_domain(CS%Grid%Domain, dG%Domain,symmetric=.false.) call set_grid_metrics(dG, PF, CS%US) call MOM_initialize_topography(dG%bathyT, dG%max_depth, dG, PF, CS%US) - call MOM_initialize_coord(CS%GV, CS%US, PF, .false., & - dirs%output_directory, tv_dummy, dG%max_depth) + call MOM_initialize_coord(CS%GV, CS%US, PF, tv_dummy, dG%max_depth) call ALE_init(PF, CS%GV, CS%US, dG%max_depth, CS%ALE_CS) call MOM_grid_init(CS%Grid, PF, global_indexing=.false.) call ALE_updateVerticalGridType(CS%ALE_CS, CS%GV) @@ -373,8 +376,8 @@ subroutine init_oda(Time, G, GV, diag_CS, CS) call cpu_clock_end(id_clock_oda_init) ! if (CS%write_obs) then -! temp_fid = open_profile_file("temp_"//trim(obs_file)) -! salt_fid = open_profile_file("salt_"//trim(obs_file)) +! temp_fid = open_profile_file("temp_"//trim(obs_file)) +! salt_fid = open_profile_file("salt_"//trim(obs_file)) ! end if end subroutine init_oda @@ -389,14 +392,9 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) type(ODA_CS), pointer :: CS !< ocean DA control structure real, dimension(SZI_(G),SZJ_(G),CS%nk) :: T, S - type(ocean_grid_type), pointer :: Grid=>NULL() - integer :: i,j, m, n, ss - integer :: is, ie, js, je + integer :: i, j, m integer :: isc, iec, jsc, jec - integer :: isd, ied, jsd, jed - integer :: isg, ieg, jsg, jeg, idg_offset, jdg_offset - integer :: id - logical :: used, symmetric + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] ! return if not time for analysis if (Time < CS%Time) return @@ -408,6 +406,14 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) call set_PElist(CS%filter_pelist) !call MOM_mesg('Setting prior') + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + ! computational domain for the analysis grid isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec ! array extents for the ensemble member @@ -416,9 +422,9 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) ! remap temperature and salinity from the ensemble member to the analysis grid do j=G%jsc,G%jec ; do i=G%isc,G%iec call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%T(i,j,:), & - CS%nk, CS%h(i,j,:), T(i,j,:)) + CS%nk, CS%h(i,j,:), T(i,j,:), h_neglect, h_neglect_edge) call remapping_core_h(CS%remapCS, GV%ke, h(i,j,:), tv%S(i,j,:), & - CS%nk, CS%h(i,j,:), S(i,j,:)) + CS%nk, CS%h(i,j,:), S(i,j,:), h_neglect, h_neglect_edge) enddo ; enddo ! cast ensemble members to the analysis domain do m=1,CS%ensemble_size @@ -450,8 +456,8 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) logical, optional, intent(in) :: increment !< True if returning increment only type(ocean_control_struct), pointer :: Ocean_increment=>NULL() - integer :: i, j, m - logical :: used, get_inc + integer :: m + logical :: get_inc integer :: seconds_per_hour = 3600. ! return if not analysis time (retain pointers for h and tv) @@ -508,10 +514,6 @@ subroutine oda(Time, CS) type(time_type), intent(in) :: Time !< the current model time type(oda_CS), pointer :: CS !< A pointer the ocean DA control structure - integer :: i, j - integer :: m - integer :: yr, mon, day, hr, min, sec - if ( Time >= CS%Time ) then !! switch to global pelist @@ -582,7 +584,7 @@ subroutine init_ocean_ensemble(CS,Grid,GV,ens_size) type(verticalGrid_type), pointer :: GV !< Pointer to DA vertical grid integer, intent(in) :: ens_size !< ensemble size - integer :: n,is,ie,js,je,nk + integer :: is, ie, js, je, nk nk=GV%ke is=Grid%isd;ie=Grid%ied @@ -643,8 +645,7 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) type(ODA_CS), pointer :: CS !< the data assimilation structure !! local variables - integer :: yr, mon, day, hr, min, sec - integer :: i, j, k + integer :: i, j integer :: isc, iec, jsc, jec real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_inc !< an adjustment to the temperature !! tendency [degC T-1 -> degC s-1] @@ -652,7 +653,7 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) !! tendency [g kg-1 T-1 -> g kg-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T !< The updated temperature [degC] real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S !< The updated salinity [g kg-1] - real :: missing_value + real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (.not. associated(CS)) return if (CS%assim_method == NO_ASSIM .and. (.not. CS%do_bias_adjustment)) return @@ -669,12 +670,20 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) S = S + CS%tv_bc%S endif + if (.not. CS%answers_2018) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + else + h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + endif + isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec do j=jsc,jec; do i=isc,iec call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T(i,j,:), & - G%ke, h(i,j,:), T_inc(i,j,:)) + G%ke, h(i,j,:), T_inc(i,j,:), h_neglect, h_neglect_edge) call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S(i,j,:), & - G%ke, h(i,j,:), S_inc(i,j,:)) + G%ke, h(i,j,:), S_inc(i,j,:), h_neglect, h_neglect_edge) enddo; enddo diff --git a/src/ocean_data_assim/MOM_oda_incupd.F90 b/src/ocean_data_assim/MOM_oda_incupd.F90 index ab3621296f..511bd89d7d 100644 --- a/src/ocean_data_assim/MOM_oda_incupd.F90 +++ b/src/ocean_data_assim/MOM_oda_incupd.F90 @@ -1,6 +1,6 @@ !> This module contains the routines used to apply incremental updates !! from data assimilation. -!! +! !! Applying incremental updates requires the following: !! 1. initialize_oda_incupd_fixed and initialize_oda_incupd !! 2. set_up_oda_incupd_field (tracers) and set_up_oda_incupd_vel_field (vel) @@ -65,8 +65,8 @@ module MOM_oda_incupd !! registered by calls to set_up_oda_incupd_field type(p3d) :: Inc(MAX_FIELDS_) !< The increments to be applied to the field - type(p3d) :: Inc_u !< The increments to be applied to the u-velocities - type(p3d) :: Inc_v !< The increments to be applied to the v-velocities + type(p3d) :: Inc_u !< The increments to be applied to the u-velocities, with data in [L T-1 ~> m s-1] + type(p3d) :: Inc_v !< The increments to be applied to the v-velocities, with data in [L T-1 ~> m s-1] type(p3d) :: Ref_h !< Vertical grid on which the increments are provided @@ -99,9 +99,6 @@ subroutine initialize_oda_incupd_fixed( G, GV, US, CS, restart_CS) !! structure for this module (in/out). type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=256) :: mesg if (associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd_fixed called with an associated "// & "control structure.") @@ -119,7 +116,7 @@ end subroutine initialize_oda_incupd_fixed !> This subroutine defined the number of time step for full update, stores the layer pressure !! increments and initialize remap structure. -subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, restart_CS) +subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h, nz_data, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -132,17 +129,16 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res !! [H ~> m or kg m-2]. type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_oda" ! This module's name. logical :: use_oda_incupd logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: reset_ncount integer :: i, j, k real :: nhours_incupd, dt, dt_therm - type(vardesc) :: vd character(len=256) :: mesg - character(len=10) :: remapScheme + character(len=64) :: remapScheme if (.not.associated(CS)) then call MOM_error(WARNING, "initialize_oda_incupd called without an associated "// & "control structure.") @@ -204,13 +200,13 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res ! get number of timestep for full update if (nhours_incupd == 0) then - CS%nstep_incupd = 1 !! direct insertion + CS%nstep_incupd = 1 !! direct insertion else - CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 + CS%nstep_incupd = floor( nhours_incupd * 3600. / dt_therm + 0.001 ) - 1 endif write(mesg,'(i12)') CS%nstep_incupd if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Number of Timestep of inc. update:"//& trim(mesg)) ! number of inc. update already done, CS%ncount, either from restart or set to 0.0 @@ -222,15 +218,16 @@ subroutine initialize_oda_incupd( G, GV, US, param_file, CS, data_h,nz_data, res endif write(mesg,'(f4.1)') CS%ncount if (is_root_pe()) & - call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& + call MOM_error(NOTE,"initialize_oda_incupd: Inc. update already done:"//& trim(mesg)) ! get the vertical grid (h_obs) of the increments CS%nz_data = nz_data allocate(CS%Ref_h%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do j=G%jsc,G%jec; do i=G%isc,G%iec ; do k=1,CS%nz_data - CS%Ref_h%p(i,j,k) = data_h(i,j,k) + CS%Ref_h%p(i,j,k) = data_h(i,j,k) enddo; enddo ; enddo + !### Doing a halo update here on CS%Ref_h%p would avoid needing halo updates each timestep. ! Call the constructor for remapping control structure call initialize_remapping(CS%remap_cs, remapScheme, boundary_extrapolation=bndExtrapolation, & @@ -265,7 +262,7 @@ subroutine set_up_oda_incupd_field(sp_val, G, GV, CS) CS%Inc(CS%fldno)%nz_data = CS%nz_data allocate(CS%Inc(CS%fldno)%p(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=0.0) do k=1,CS%nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) + CS%Inc(CS%fldno)%p(i,j,k) = sp_val(i,j,k) enddo ; enddo ; enddo end subroutine set_up_oda_incupd_field @@ -329,17 +326,17 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) real, dimension(SZK_(GV)) :: tmp_val1 ! data values on the model grid real, allocatable, dimension(:) :: tmp_val2 ! data values remapped to increment grid - real, allocatable, dimension(:,:,:) :: h_obs !< h of increments - real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_obs !< Layer-thicknesses of increments [H ~> m or kg m-2] + real, allocatable, dimension(:) :: tmp_h ! temporary array for corrected h_obs [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's - character(len=256) :: mesg + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB @@ -375,122 +372,122 @@ subroutine calc_oda_increments(h, tv, u, v, G, GV, US, CS) ! remap t,s (on h_init) to h_obs to get increment tmp_val1(:) = 0.0 do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) == 1) then + if (G%mask2dT(i,j) == 1) then + ! account for the different SSH + sum_h1 = 0.0 + sum_h2 = 0.0 + do k=1,nz + sum_h1 = sum_h1+h(i,j,k) + enddo + + do k=1,nz_data + sum_h2 = sum_h2+h_obs(i,j,k) + enddo + do k=1,nz_data + tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) + enddo + ! get temperature + do k=1,nz + tmp_val1(k) = tv%T(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + enddo + + ! get salinity + do k=1,nz + tmp_val1(k) = tv%S(i,j,k) + enddo + ! remap tracer on h_obs + call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & + nz_data, tmp_h(1:nz_data), tmp_val2, & + h_neglect, h_neglect_edge) + ! get increment from full field on h_obs + do k=1,nz_data + CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + enddo + endif + enddo ; enddo + + ! remap u to h_obs to get increment + if (CS%uv_inc) then + call pass_var(h, G%Domain) + + hu(:) = 0.0 + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + ! get u-velocity + do k=1,nz + tmp_val1(k) = u(i,j,k) + ! get the h and h_obs at u points + hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) + enddo + do k=1,nz_data + hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) + enddo ! account for the different SSH sum_h1 = 0.0 - sum_h2 = 0.0 do k=1,nz - sum_h1 = sum_h1+h(i,j,k) + sum_h1 = sum_h1+hu(k) enddo - + sum_h2 = 0.0 do k=1,nz_data - sum_h2 = sum_h2+h_obs(i,j,k) + sum_h2 = sum_h2+hu_obs(k) enddo do k=1,nz_data - tmp_h(k)=(sum_h1/sum_h2)*h_obs(i,j,k) - enddo - ! get temperature - do k=1,nz - tmp_val1(k) = tv%T(i,j,k) + hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + ! remap model u on hu_obs + call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & + nz_data, hu_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(1)%p(i,j,k) = CS%Inc(1)%p(i,j,k) - tmp_val2(k) + CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) enddo - - ! get salinity + endif + enddo ; enddo + + ! remap v to h_obs to get increment + hv(:) = 0.0; + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v-velocity do k=1,nz - tmp_val1(k) = tv%S(i,j,k) + tmp_val1(k) = v(i,j,k) + ! get the h and h_obs at v points + hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) + enddo + do k=1,nz_data + hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) + enddo + ! account for the different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1+hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2+hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) enddo - ! remap tracer on h_obs - call remapping_core_h(CS%remap_cs, nz, h(i,j,1:nz), tmp_val1, & - nz_data, tmp_h(1:nz_data), tmp_val2, & + ! remap model v on hv_obs + call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & + nz_data, hv_obs(1:nz_data), tmp_val2, & h_neglect, h_neglect_edge) ! get increment from full field on h_obs do k=1,nz_data - CS%Inc(2)%p(i,j,k) = CS%Inc(2)%p(i,j,k) - tmp_val2(k) + CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) enddo - endif - enddo; enddo - - ! remap u to h_obs to get increment - if (CS%uv_inc) then - call pass_var(h, G%Domain) - - hu(:) = 0.0 - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - ! get u-velocity - do k=1,nz - tmp_val1(k) = u(i,j,k) - ! get the h and h_obs at u points - hu(k) = 0.5*( h(i,j,k)+ h(i+1,j,k)) - enddo - do k=1,nz_data - hu_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i+1,j,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=(sum_h1/sum_h2)*hu_obs(k) - enddo - ! remap model u on hu_obs - call remapping_core_h(CS%remap_cs, nz, hu(1:nz), tmp_val1, & - nz_data, hu_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_u%p(i,j,k) = CS%Inc_u%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo - - ! remap v to h_obs to get increment - hv(:) = 0.0; - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v-velocity - do k=1,nz - tmp_val1(k) = v(i,j,k) - ! get the h and h_obs at v points - hv(k) = 0.5*(h(i,j,k)+h(i,j+1,k)) - enddo - do k=1,nz_data - hv_obs(k) = 0.5*(h_obs(i,j,k)+h_obs(i,j+1,k)) - enddo - ! account for the different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1+hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2+hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=(sum_h1/sum_h2)*hv_obs(k) - enddo - ! remap model v on hv_obs - call remapping_core_h(CS%remap_cs, nz, hv(1:nz), tmp_val1, & - nz_data, hv_obs(1:nz_data), tmp_val2, & - h_neglect, h_neglect_edge) - ! get increment from full field on h_obs - do k=1,nz_data - CS%Inc_v%p(i,j,k) = CS%Inc_v%p(i,j,k) - tmp_val2(k) - enddo - endif - enddo; enddo + endif + enddo ; enddo endif ! uv_inc call pass_var(CS%Inc(1)%p, G%Domain) @@ -524,26 +521,26 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) type(oda_incupd_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_oda_incupd (in). - real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the increment grid real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid - real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: hu, hv ! A column of thicknesses at u or v points [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t inc. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s inc. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u inc. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v inc. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_t !< A temporary array for t increments [degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tmp_s !< A temporary array for s increments [ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: tmp_u !< A temporary array for u increments [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: tmp_v !< A temporary array for v increments [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:) :: h_obs !< h of increments real, allocatable, dimension(:) :: tmp_h !< temporary array for corrected h_obs - real, allocatable, dimension(:) :: hu_obs,hv_obs ! A column of thicknesses at h points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hu_obs ! A column of observation-grid thicknesses at u points [H ~> m or kg m-2] + real, allocatable, dimension(:) :: hv_obs ! A column of observation-grid thicknesses at v points [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, nz_data integer :: isB, ieB, jsB, jeB ! integer :: ncount ! time step counter - real :: inc_wt ! weight of the update for this time-step - real :: h_neglect, h_neglect_edge - real :: sum_h1, sum_h2 !vertical sums of h's + real :: inc_wt ! weight of the update for this time-step [nondim] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: sum_h1, sum_h2 ! vertical sums of h's [H ~> m or kg m-2] character(len=256) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -603,118 +600,118 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) tmp_h(k) = ( sum_h1 / sum_h2 ) * h_obs(i,j,k) enddo if (G%mask2dT(i,j) == 1) then - ! get temperature increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(1)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - do k=1,nz - ! add increment to tracer on model h - tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) - tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics - enddo - - ! get salinity increment - do k=1,nz_data - tmp_val2(k) = CS%Inc(2)%p(i,j,k) - enddo - ! remap increment profile on model h - call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& - nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) - ! add increment to tracer on model h - do k=1,nz - tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) - tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics - ! bound salinity values ! check if it is correct to do that or if it hides - ! other problems ... - tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) - enddo + ! get temperature increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(1)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data), tmp_val2, & + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + do k=1,nz + ! add increment to tracer on model h + tv%T(i,j,k) = tv%T(i,j,k) + inc_wt * tmp_val1(k) + tmp_t(i,j,k) = tmp_val1(k) ! store T increment for diagnostics + enddo + + ! get salinity increment + do k=1,nz_data + tmp_val2(k) = CS%Inc(2)%p(i,j,k) + enddo + ! remap increment profile on model h + call remapping_core_h(CS%remap_cs, nz_data, tmp_h(1:nz_data),tmp_val2,& + nz, h(i,j,1:nz),tmp_val1, h_neglect, h_neglect_edge) + ! add increment to tracer on model h + do k=1,nz + tv%S(i,j,k) = tv%S(i,j,k) + inc_wt * tmp_val1(k) + tmp_s(i,j,k) = tmp_val1(k) ! store S increment for diagnostics + ! bound salinity values ! check if it is correct to do that or if it hides + ! other problems ... + tv%S(i,j,k) = max(0.0 , tv%S(i,j,k)) + enddo endif - enddo; enddo + enddo ; enddo ! add u and v increments if (CS%uv_inc) then - call pass_var(h,G%Domain) ! to ensure reproducibility - - ! add increments to u - hu(:) = 0.0 - tmp_u(:,:,:) = 0.0 ! diagnostics - do j=js,je ; do i=isB,ieB - if (G%mask2dCu(i,j) == 1) then - do k=1,nz_data - ! get u increment - tmp_val2(k) = CS%Inc_u%p(i,j,k) - ! get the h and h_obs at u points - hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) - enddo - do k=1,nz - hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hu(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hu_obs(k) - enddo - do k=1,nz_data - hu_obs(k)=( sum_h1 / sum_h2 ) * hu_obs(k) - enddo - ! remap increment profile on hu - call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & - nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to u-velocity on hu - do k=1,nz - u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_u(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo - - ! add increments to v - hv(:) = 0.0 - tmp_v(:,:,:) = 0.0 ! diagnostics - do j=jsB,jeB ; do i=is,ie - if (G%mask2dCv(i,j) == 1) then - ! get v increment - do k=1,nz_data - tmp_val2(k) = CS%Inc_v%p(i,j,k) - ! get the h and h_obs at v points - hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) - enddo - do k=1,nz - hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) - enddo - ! account for different SSH - sum_h1 = 0.0 - do k=1,nz - sum_h1 = sum_h1 + hv(k) - enddo - sum_h2 = 0.0 - do k=1,nz_data - sum_h2 = sum_h2 + hv_obs(k) - enddo - do k=1,nz_data - hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) - enddo - ! remap increment profile on hv - call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & - nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) - ! add increment to v-velocity on hv - do k=1,nz - v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) - ! store increment for diagnostics - tmp_v(i,j,k) = tmp_val1(k) - enddo - endif - enddo; enddo + call pass_var(h,G%Domain) ! to ensure reproducibility + + ! add increments to u + hu(:) = 0.0 + tmp_u(:,:,:) = 0.0 ! diagnostics + do j=js,je ; do i=isB,ieB + if (G%mask2dCu(i,j) == 1) then + do k=1,nz_data + ! get u increment + tmp_val2(k) = CS%Inc_u%p(i,j,k) + ! get the h and h_obs at u points + hu_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i+1,j,k) ) + enddo + do k=1,nz + hu(k) = 0.5 * ( h(i,j,k) + h(i+1,j,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hu(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hu_obs(k) + enddo + do k=1,nz_data + hu_obs(k) = ( sum_h1 / sum_h2 ) * hu_obs(k) + enddo + ! remap increment profile on hu + call remapping_core_h(CS%remap_cs, nz_data, hu_obs(1:nz_data), tmp_val2, & + nz, hu(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to u-velocity on hu + do k=1,nz + u(i,j,k) = u(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_u(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo + + ! add increments to v + hv(:) = 0.0 + tmp_v(:,:,:) = 0.0 ! diagnostics + do j=jsB,jeB ; do i=is,ie + if (G%mask2dCv(i,j) == 1) then + ! get v increment + do k=1,nz_data + tmp_val2(k) = CS%Inc_v%p(i,j,k) + ! get the h and h_obs at v points + hv_obs(k) = 0.5 * ( h_obs(i,j,k) + h_obs(i,j+1,k) ) + enddo + do k=1,nz + hv(k) = 0.5 * (h(i,j,k) + h(i,j+1,k) ) + enddo + ! account for different SSH + sum_h1 = 0.0 + do k=1,nz + sum_h1 = sum_h1 + hv(k) + enddo + sum_h2 = 0.0 + do k=1,nz_data + sum_h2 = sum_h2 + hv_obs(k) + enddo + do k=1,nz_data + hv_obs(k)=( sum_h1 / sum_h2 ) * hv_obs(k) + enddo + ! remap increment profile on hv + call remapping_core_h(CS%remap_cs, nz_data, hv_obs(1:nz_data), tmp_val2, & + nz, hv(1:nz), tmp_val1, h_neglect, h_neglect_edge) + ! add increment to v-velocity on hv + do k=1,nz + v(i,j,k) = v(i,j,k) + inc_wt * tmp_val1(k) + ! store increment for diagnostics + tmp_v(i,j,k) = tmp_val1(k) + enddo + endif + enddo ; enddo endif ! uv_inc @@ -735,7 +732,7 @@ subroutine apply_oda_incupd(h, tv, u, v, dt, G, GV, US, CS) deallocate(tmp_h,tmp_val2,hu_obs,hv_obs) deallocate(h_obs) - end subroutine apply_oda_incupd +end subroutine apply_oda_incupd !> Output increment if using full fields for the oda_incupd module. subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) @@ -771,12 +768,12 @@ subroutine output_oda_incupd_inc(Time, G, GV, param_file, CS, US) call register_restart_field(CS%Inc(2)%p, "S_inc", .true., restart_CSp_tmp, & "Salinity increment", "psu") call register_restart_field(CS%Ref_h%p, "h_obs", .true., restart_CSp_tmp, & - "Observational h", "m") + "Observational h", units=get_thickness_units(GV), conversion=GV%H_to_MKS) if (CS%uv_inc) then u_desc = var_desc("u_inc", "m s-1", "U-vel increment", hor_grid='Cu') v_desc = var_desc("v_inc", "m s-1", "V-vel increment", hor_grid='Cv') call register_restart_pair(CS%Inc_u%p, CS%Inc_v%p, u_desc, v_desc, & - .false., restart_CSp_tmp) + .false., restart_CSp_tmp, conversion=US%L_T_to_m_s) endif ! get the name of the output file diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index c786f395cf..bde8632170 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -14,7 +14,6 @@ module MOM_MEKE use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc use MOM_restart, only : MOM_restart_CS, register_restart_field, query_initialized use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type @@ -706,8 +705,6 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration - real :: Lgrid, Ldeform, Lfrict - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec debugIteration = .false. @@ -1037,7 +1034,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. real :: cdrag ! The default bottom drag coefficient [nondim]. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - logical :: laplacian, biharmonic, useVarMix, coldStart + logical :: laplacian, biharmonic, coldStart ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_MEKE" ! This module's name. @@ -1326,16 +1323,16 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) ! Account for possible changes in dimensional scaling for variables that have been ! read from a restart file. I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T + if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) & + I_T_rescale = US%s_to_T_restart L_rescale = 1.0 - if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= US%m_to_L)) & - L_rescale = US%m_to_L / US%m_to_L_restart + if ((US%m_to_L_restart /= 0.0) .and. (US%m_to_L_restart /= 1.0)) & + L_rescale = 1.0 / US%m_to_L_restart if (L_rescale*I_T_rescale /= 1.0) then if (allocated(MEKE%MEKE)) then ; if (query_initialized(MEKE%MEKE, "MEKE_MEKE", restart_CS)) then do j=js,je ; do i=is,ie - MEKE%MEKE(i,j) = L_rescale*I_T_rescale * MEKE%MEKE(i,j) + MEKE%MEKE(i,j) = (L_rescale*I_T_rescale)**2 * MEKE%MEKE(i,j) enddo ; enddo endif ; endif endif @@ -1380,15 +1377,17 @@ logical function MEKE_init(Time, G, US, param_file, diag, CS, MEKE, restart_CS) end function MEKE_init !> Allocates memory and register restart fields for the MOM_MEKE module. -subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) +subroutine MEKE_alloc_register_restart(HI, US, param_file, MEKE, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index 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. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct -! Local variables - type(vardesc) :: vd - real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff, MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au + + ! Local variables + real :: MEKE_GMcoeff, MEKE_FrCoeff, MEKE_GMECoeff ! Coefficients for various terms [nondim] + real :: MEKE_KHCoeff, MEKE_viscCoeff_Ku, MEKE_viscCoeff_Au ! Coefficients for various terms [nondim] logical :: Use_KH_in_MEKE logical :: useMEKE integer :: isd, ied, jsd, jed @@ -1397,13 +1396,13 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) useMEKE = .false.; call read_param(param_file,"USE_MEKE",useMEKE) ! Read these parameters to determine what should be in the restarts - MEKE_GMcoeff =-1.; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) - MEKE_FrCoeff =-1.; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) - MEKE_GMEcoeff =-1.; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) - MEKE_KhCoeff =1.; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) - MEKE_viscCoeff_Ku =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) - MEKE_viscCoeff_Au =0.; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) - Use_KH_in_MEKE = .false.; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) + MEKE_GMcoeff = -1. ; call read_param(param_file,"MEKE_GMCOEFF",MEKE_GMcoeff) + MEKE_FrCoeff = -1. ; call read_param(param_file,"MEKE_FRCOEFF",MEKE_FrCoeff) + MEKE_GMEcoeff = -1. ; call read_param(param_file,"MEKE_GMECOEFF",MEKE_GMEcoeff) + MEKE_KhCoeff = 1. ; call read_param(param_file,"MEKE_KHCOEFF",MEKE_KhCoeff) + MEKE_viscCoeff_Ku = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_KU",MEKE_viscCoeff_Ku) + MEKE_viscCoeff_Au = 0. ; call read_param(param_file,"MEKE_VISCOSITY_COEFF_AU",MEKE_viscCoeff_Au) + Use_KH_in_MEKE = .false. ; call read_param(param_file,"USE_KH_IN_MEKE", Use_KH_in_MEKE) if (.not. useMEKE) return @@ -1411,38 +1410,38 @@ subroutine MEKE_alloc_register_restart(HI, param_file, MEKE, restart_CS) call MOM_mesg("MEKE_alloc_register_restart: allocating and registering", 5) isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed allocate(MEKE%MEKE(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE", "m2 s-2", hor_grid='h', z_grid='1', & - longname="Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%MEKE, vd, .false., restart_CS) + call register_restart_field(MEKE%MEKE, "MEKE", .false., restart_CS, & + longname="Mesoscale Eddy Kinetic Energy", units="m2 s-2", conversion=US%L_T_to_m_s**2) + if (MEKE_GMcoeff>=0.) allocate(MEKE%GM_src(isd:ied,jsd:jed), source=0.0) if (MEKE_FrCoeff>=0. .or. MEKE_GMECoeff>=0.) & allocate(MEKE%mom_src(isd:ied,jsd:jed), source=0.0) if (MEKE_GMECoeff>=0.) allocate(MEKE%GME_snk(isd:ied,jsd:jed), source=0.0) if (MEKE_KhCoeff>=0.) then allocate(MEKE%Kh(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Kh", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Kh, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh, "MEKE_Kh", .false., restart_CS, & + longname="Lateral diffusivity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif allocate(MEKE%Rd_dx_h(isd:ied,jsd:jed), source=0.0) if (MEKE_viscCoeff_Ku/=0.) then allocate(MEKE%Ku(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Ku", "m2 s-1", hor_grid='h', z_grid='1', & - longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Ku, vd, .false., restart_CS) + call register_restart_field(MEKE%Ku, "MEKE_Ku", .false., restart_CS, & + longname="Lateral viscosity from Mesoscale Eddy Kinetic Energy", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif if (Use_Kh_in_MEKE) then allocate(MEKE%Kh_diff(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Kh_diff", "m2 s-1",hor_grid='h',z_grid='1', & - longname="Copy of thickness diffusivity for diffusing MEKE") - call register_restart_field(MEKE%Kh_diff, vd, .false., restart_CS) + call register_restart_field(MEKE%Kh_diff, "MEKE_Kh_diff", .false., restart_CS, & + longname="Copy of thickness diffusivity for diffusing MEKE", & + units="m2 s-1", conversion=US%L_to_m**2*US%s_to_T) endif if (MEKE_viscCoeff_Au/=0.) then allocate(MEKE%Au(isd:ied,jsd:jed), source=0.0) - vd = var_desc("MEKE_Au", "m4 s-1", hor_grid='h', z_grid='1', & - longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy") - call register_restart_field(MEKE%Au, vd, .false., restart_CS) + call register_restart_field(MEKE%Au, "MEKE_Au", .false., restart_CS, & + longname="Lateral biharmonic viscosity from Mesoscale Eddy Kinetic Energy", & + units="m4 s-1", conversion=US%L_to_m**4*US%s_to_T) endif end subroutine MEKE_alloc_register_restart diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0249f79c2d..f7235998a6 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2,14 +2,14 @@ module MOM_hor_visc ! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_checksums, only : hchksum, Bchksum +use MOM_checksums, only : hchksum, Bchksum, uvchksum use MOM_coms, only : min_across_PEs 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 use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER, pass_vector, AGRID, BGRID_NE +use MOM_domains, only : To_All, Scalar_Pair use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -185,6 +185,7 @@ module MOM_hor_visc ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. ! The code is retained for degugging purposes in the future. + integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes. !>@{ !! Diagnostic id integer :: id_grid_Re_Ah = -1, id_grid_Re_Kh = -1 @@ -197,6 +198,8 @@ module MOM_hor_visc integer :: id_Ah_h = -1, id_Ah_q = -1 integer :: id_Kh_h = -1, id_Kh_q = -1 integer :: id_GME_coeff_h = -1, id_GME_coeff_q = -1 + integer :: id_dudx_bt = -1, id_dvdy_bt = -1 + integer :: id_dudy_bt = -1, id_dvdx_bt = -1 integer :: id_vort_xy_q = -1, id_div_xx_h = -1 integer :: id_sh_xy_q = -1, id_sh_xx_h = -1 integer :: id_FrictWork = -1, id_FrictWorkIntz = -1 @@ -270,20 +273,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] - Del2vort_h, & ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 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] - grad_vel_mag_h, & ! Magnitude of the velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_vel_mag_bt_h, & ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] - grad_d2vel_mag_h, & ! Magnitude of the Laplacian of the velocity vector, squared [L-2 T-2 ~> m-2 s-2] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot, & ! The total thickness of all layers [Z ~> m] - boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] - - real, allocatable, dimension(:,:,:) :: h_diffu ! h x diffu [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: h_diffv ! h x diffv [H L T-2 ~> m2 s-2] - real, allocatable, dimension(:,:,:) :: diffu_visc_rem ! diffu x visc_rem_u [L T-2 ~> m s-2] - real, allocatable, dimension(:,:,:) :: diffv_visc_rem ! diffv x visc_rem_v [L T-2 ~> m s-2] + htot ! The total thickness of all layers [Z ~> m] + 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] @@ -295,18 +291,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xy_GME, & ! smoothed cross term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg 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] - Leith_Kh_q, & ! Leith Laplacian viscosity at q-points [L2 T-1 ~> m2 s-1] - Leith_Ah_q, & ! Leith bi-harmonic viscosity at q-points [L4 T-1 ~> m4 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] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] - grad_vel_mag_q, & ! Magnitude of the velocity gradient tensor squared at q-points [T-2 ~> s-2] hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] ! This form guarantees that hq/hu < 4. - grad_vel_mag_bt_q, & ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] - GME_effic_q, & ! The filtered efficiency of the GME terms at q points [nondim] - boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] + GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] + real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & Ah_q, & ! biharmonic viscosity at corner points [L4 T-1 ~> m4 s-1] @@ -333,9 +326,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, GME_coeff_h ! GME coeff. at h-points [L2 T-1 ~> m2 s-1] real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] - real :: mod_Leith ! nondimensional coefficient for divergence part of modified Leith - ! viscosity. Here set equal to nondimensional Laplacian Leith constant. - ! This is set equal to zero if modified Leith is not used. 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] @@ -344,29 +334,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! points; these are first interpolated to u or v velocity ! points where masks are applied [H ~> m or kg m-2]. real :: h_arith_q ! The arithmetic mean total thickness at q points [Z ~> m] - real :: h_harm_q ! The harmonic mean total thickness at q points [Z ~> m] - real :: I_hq ! The inverse of the arithmetic mean total thickness at q points [Z-1 ~> m-1] real :: I_GME_h0 ! The inverse of GME tapering scale [Z-1 ~> m-1] 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 :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] - real :: Kh_scale ! A factor between 0 and 1 by which the horizontal - ! Laplacian viscosity is rescaled [nondim] real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] - real :: GME_coeff_limiter ! Maximum permitted value of the GME coefficient [L2 T-1 ~> m2 s-1] - real :: FWfrac ! Fraction of maximum theoretical energy transfer to use when scaling GME coefficient [nondim] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] - real :: DY_dxCv ! Ratio of meridional over zonal grid spacing at faces [nondim] - real :: DX_dyCu ! Ratio of zonal over meridional grid spacing at faces [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. - real :: H0_GME ! Depth used to scale down GME coefficient in shallow areas [Z ~> m] real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] real :: d_del2u ! dy-weighted Laplacian(u) diff in x [L-2 T-1 ~> m-2 s-1] real :: d_del2v ! dx-weighted Laplacian(v) diff in y [L-2 T-1 ~> m-2 s-1] @@ -388,21 +369,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Fields evaluated on active layers, used for constructing 3D stress fields ! NOTE: The position of these declarations can impact performance, due to the ! very large number of stack arrays in this function. Move with caution! + ! NOTE: Several of these are declared with the memory extent of q-points, but the + ! same arrays are also used at h-points to reduce the memory footprint of this + ! module, so they should never be used in halo point or checksum calls. real, dimension(SZIB_(G),SZJB_(G)) :: & Ah, & ! biharmonic viscosity (h or q) [L4 T-1 ~> m4 s-1] - Kh, & ! Laplacian viscosity [L2 T-1 ~> m2 s-1] - Shear_mag, & ! magnitude of the shear [T-1 ~> s-1] - vert_vort_mag, & ! magnitude of the vertical vorticity gradient [L-1 T-1 ~> m-1 s-1] + 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] 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 [nondim] - - real, dimension(SZIB_(G),SZJ_(G)) :: & - hf_diffu_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffu_2d ! Depth-integral of diffu [H L T-2 ~> m2 s-2] - - real, dimension(SZI_(G),SZJB_(G)) :: & - hf_diffv_2d, & ! Depth sum of hf_diffu, hf_diffv [L T-2 ~> m s-2] - intz_diffv_2d ! Depth-integral of diffv [H L T-2 ~> m2 s-2] + visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] 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 @@ -452,13 +428,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (CS%bound_Kh .and. .not.CS%better_bound_Kh) if (CS%use_GME) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - boundary_mask_h(i,j) = (G%mask2dCu(I,j) * G%mask2dCv(i,J) * G%mask2dCu(I-1,j) * G%mask2dCv(i,J-1)) - enddo ; enddo - - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - boundary_mask_q(I,J) = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J) * G%mask2dCu(I,j) * G%mask2dCu(I,j-1)) - enddo ; enddo ! initialize diag. array with zeros GME_coeff_h(:,:,:) = 0.0 @@ -468,81 +437,83 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Get barotropic velocities and their gradients call barotropic_get_tav(BT, ubtav, vbtav, G, US) + call pass_vector(ubtav, vbtav, G%Domain) + call pass_var(h, G%domain, halo=2) - do j=js-1,je+2 ; do i=is-1,ie+2 + ! Calculate the barotropic horizontal tension + do J=js-2,je+2 ; do I=is-2,ie+2 dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & G%IdyCu(I-1,j) * ubtav(I-1,j)) dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & G%IdxCv(i,J-1) * vbtav(i,J-1)) enddo ; enddo - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 sh_xx_bt(i,j) = dudx_bt(i,j) - dvdy_bt(i,j) enddo ; enddo ! Components for the barotropic shearing strain - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 dvdx_bt(I,J) = CS%DY_dxBu(I,J)*(vbtav(i+1,J)*G%IdyCv(i+1,J) & - vbtav(i,J)*G%IdyCv(i,J)) dudy_bt(I,J) = CS%DX_dyBu(I,J)*(ubtav(I,j+1)*G%IdxCu(I,j+1) & - ubtav(I,j)*G%IdxCu(I,j)) enddo ; enddo - call pass_vector(dudx_bt, dvdy_bt, G%Domain, stagger=BGRID_NE) - call pass_vector(dvdx_bt, dudy_bt, G%Domain, stagger=AGRID) - if (CS%no_slip) then - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo else - do J=js-1,Jeq ; do I=is-1,Ieq + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo endif - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - grad_vel_mag_bt_h(i,j) = boundary_mask_h(i,j) * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & - (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1))+(dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & - (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1))+(dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) - enddo ; enddo - - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 - grad_vel_mag_bt_q(I,J) = boundary_mask_q(I,J) * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & - (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1))+(dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & - (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1))+(dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) - enddo ; enddo - - do j=js-1,je+1 ; do i=is-1,ie+1 + do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = 0.0 enddo ; enddo - do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 htot(i,j) = htot(i,j) + GV%H_to_Z*h(i,j,k) enddo ; enddo ; enddo I_GME_h0 = 1.0 / CS%GME_h0 - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (grad_vel_mag_bt_h(i,j)>0) then - GME_effic_h(i,j) = CS%GME_efficiency * boundary_mask_h(i,j) * & - (MIN(htot(i,j) * I_GME_h0, 1.0)**2) + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + boundary_mask_h = (G%mask2dCu(I,j) * G%mask2dCu(I-1,j)) * (G%mask2dCv(i,J) * G%mask2dCv(i,J-1)) + grad_vel_mag_bt_h = G%mask2dT(I,J) * boundary_mask_h * (dudx_bt(i,j)**2 + dvdy_bt(i,j)**2 + & + (0.25*((dvdx_bt(I,J)+dvdx_bt(I-1,J-1)) + (dvdx_bt(I,J-1)+dvdx_bt(I-1,J))))**2 + & + (0.25*((dudy_bt(I,J)+dudy_bt(I-1,J-1)) + (dudy_bt(I,J-1)+dudy_bt(I-1,J))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_h * G%mask2dT(I,J) > 0.0) then + if (grad_vel_mag_bt_h > 0.0) then + GME_effic_h(i,j) = CS%GME_efficiency * G%mask2dT(I,J) * (MIN(htot(i,j) * I_GME_h0, 1.0)**2) else GME_effic_h(i,j) = 0.0 endif enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - if (grad_vel_mag_bt_q(I,J)>0) then + do J=js-2,je+1 ; do I=is-2,ie+1 + boundary_mask_q = (G%mask2dCv(i,J) * G%mask2dCv(i+1,J)) * (G%mask2dCu(I,j) * G%mask2dCu(I,j+1)) + grad_vel_mag_bt_q = G%mask2dBu(I,J) * boundary_mask_q * (dvdx_bt(I,J)**2 + dudy_bt(I,J)**2 + & + (0.25*((dudx_bt(i,j)+dudx_bt(i+1,j+1)) + (dudx_bt(i,j+1)+dudx_bt(i+1,j))))**2 + & + (0.25*((dvdy_bt(i,j)+dvdy_bt(i+1,j+1)) + (dvdy_bt(i,j+1)+dvdy_bt(i+1,j))))**2) + ! Probably the following test could be simplified to + ! if (boundary_mask_q * G%mask2dBu(I,J) > 0.0) then + if (grad_vel_mag_bt_q > 0.0) then h_arith_q = 0.25 * ((htot(i,j) + htot(i+1,j+1)) + (htot(i+1,j) + htot(i,j+1))) - I_hq = 1.0 / h_arith_q - h_harm_q = 0.25 * h_arith_q * ((htot(i,j)*I_hq + htot(i+1,j+1)*I_hq) + & - (htot(i+1,j)*I_hq + htot(i,j+1)*I_hq)) - GME_effic_q(I,J) = CS%GME_efficiency * boundary_mask_q(I,J) * (MIN(h_harm_q * I_GME_h0, 1.0)**2) + GME_effic_q(I,J) = CS%GME_efficiency * G%mask2dBu(I,J) * (MIN(h_arith_q * I_GME_h0, 1.0)**2) else GME_effic_q(I,J) = 0.0 endif enddo ; enddo + call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) + + call pass_vector(KH_u_GME, KH_v_GME, G%domain, To_All+Scalar_Pair) + + if (CS%debug) & + call uvchksum("GME KH[u,v]_GME", KH_u_GME, KH_v_GME, G%HI, haloshift=2, scale=US%L_to_m**2*US%s_to_T) + endif ! use_GME !$OMP parallel do default(none) & @@ -550,12 +521,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, boundary_mask_h, boundary_mask_q, & - !$OMP backscat_subround, GME_coeff_limiter, GME_effic_h, GME_effic_q, & - !$OMP h_neglect, h_neglect3, FWfrac, inv_PI3, inv_PI6, H0_GME, & + !$OMP use_MEKE_Ku, use_MEKE_Au, & + !$OMP backscat_subround, GME_effic_h, GME_effic_q, & + !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP TD, KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & @@ -565,12 +536,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP vort_xy, vort_xy_dx, vort_xy_dy, div_xx, div_xx_dx, div_xx_dy, & !$OMP grad_div_mag_h, grad_div_mag_q, grad_vort_mag_h, grad_vort_mag_q, & !$OMP grad_vort, grad_vort_qg, grad_vort_mag_h_2d, grad_vort_mag_q_2d, & - !$OMP grad_vel_mag_h, grad_vel_mag_q, & - !$OMP grad_vel_mag_bt_h, grad_vel_mag_bt_q, grad_d2vel_mag_h, & + !$OMP sh_xx_sq, sh_xy_sq, & !$OMP meke_res_fn, Shear_mag, Shear_mag_bc, vert_vort_mag, h_min, hrat_min, visc_bound_rem, & - !$OMP sh_xx_sq, sh_xy_sq, grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & + !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & - !$OMP dDel2vdx, dDel2udy, DY_dxCv, DX_dyCu, Del2vort_q, Del2vort_h, KE, & + !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & !$OMP ) do k=1,nz @@ -816,9 +786,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) enddo ; enddo - do J=Jsq,Jeq+1 ; do I=Isq,Ieq+1 - Del2vort_h(i,j) = 0.25*(Del2vort_q(I,J) + Del2vort_q(I-1,J) + Del2vort_q(I,J-1) + Del2vort_q(I-1,J-1)) - enddo ; enddo if (CS%modified_Leith) then @@ -1002,8 +969,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then visc_bound_rem(i,j) = 0.0 Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) - else - ! ### NOTE: The denominator could be zero here - AJA ### + else ! if (Kh(i,j) > 0.0) then !### Change this to avoid a zero denominator. visc_bound_rem(i,j) = 1.0 - Kh(i,j) / (hrat_min(i,j) * CS%Kh_Max_xx(i,j)) endif enddo ; enddo @@ -1079,7 +1045,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Ah) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h(i,j)) * inv_PI6 + 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) * abs(Del2vort_h) * inv_PI6 Ah(i,j) = max(Ah(i,j), AhLth) enddo ; enddo endif @@ -1200,7 +1168,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%better_bound_Kh) then do J=js-1,Jeq ; do I=is-1,Ieq - visc_bound_rem(i,j) = 1.0 + visc_bound_rem(I,J) = 1.0 enddo ; enddo endif endif @@ -1249,17 +1217,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Static (pre-computed) background viscosity do J=js-1,Jeq ; do I=is-1,Ieq - Kh(i,j) = CS%Kh_bg_xy(i,j) + Kh(I,J) = CS%Kh_bg_xy(I,J) enddo ; enddo if (CS%Smagorinsky_Kh) then if (CS%add_LES_viscosity) then do J=js-1,Jeq ; do I=is-1,Ieq - Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) + Kh(I,J) = Kh(I,J) + CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(i,j) ) + Kh(I,J) = max(Kh(I,J), CS%Laplac2_const_xy(I,J) * Shear_mag(I,J) ) enddo ; enddo endif endif @@ -1267,7 +1235,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Leith_Kh) then if (CS%add_LES_viscosity) then do J=js-1,Jeq ; do I=is-1,Ieq - Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xx(i,j) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA + Kh(I,J) = Kh(I,J) + CS%Laplac3_const_xy(I,J) * vert_vort_mag(I,J) * inv_PI3 ! Is this right? -AJA enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1299,17 +1267,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (MEKE%Ku(i+1,j) + MEKE%Ku(i,j+1)) ) * meke_res_fn endif - ! Older method of bounding for stability if (CS%anisotropic) & ! *Add* the shear component of anisotropic viscosity Kh(I,J) = Kh(I,J) + CS%Kh_aniso * CS%n1n2_q(I,J)**2 ! Newer method of bounding for stability if (CS%better_bound_Kh) then - if (Kh(i,j) >= hrat_min(I,J) * CS%Kh_Max_xy(I,J)) then - visc_bound_rem(i,j) = 0.0 - Kh(i,j) = hrat_min(I,J) * CS%Kh_Max_xy(I,J) - elseif (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then + if (Kh(I,J) >= hrat_min(I,J) * CS%Kh_Max_xy(I,J)) then + visc_bound_rem(I,J) = 0.0 + Kh(I,J) = hrat_min(I,J) * CS%Kh_Max_xy(I,J) + elseif (hrat_min(I,J)*CS%Kh_Max_xy(I,J)>0.) then !### Change to elseif (Kh(I,J) > 0.0) then visc_bound_rem(I,J) = 1.0 - Kh(I,J) / (hrat_min(I,J) * CS%Kh_Max_xy(I,J)) endif endif @@ -1325,7 +1292,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(i,j) * sh_xy(I,J) + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1338,7 +1305,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Horizontal-tension averaged to q-points local_strain = 0.25 * ( (sh_xx(i,j) + sh_xx(i+1,j+1)) + (sh_xx(i+1,j) + sh_xx(i,j+1)) ) ! *Add* the tension contribution to the xy-component of stress - str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(i,j) * CS%n1n1_m_n2n2_q(i,j) * local_strain + str_xy(I,J) = str_xy(I,J) - CS%Kh_aniso * CS%n1n2_q(I,J) * CS%n1n1_m_n2n2_q(I,J) * local_strain enddo ; enddo endif @@ -1346,7 +1313,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Determine the biharmonic viscosity at q points, using the ! largest value from several parameterizations. do J=js-1,Jeq ; do I=is-1,Ieq - Ah(i,j) = CS%Ah_bg_xy(I,J) + Ah(I,J) = CS%Ah_bg_xy(I,J) enddo ; enddo if (CS%Smagorinsky_Ah .or. CS%Leith_Ah) then @@ -1356,7 +1323,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, AhSm = Shear_mag(I,J) * (CS%Biharm_const_xy(I,J) & + CS%Biharm_const2_xy(I,J) * Shear_mag(I,J) & ) - Ah(i,j) = max(Ah(I,J), AhSm) + Ah(I,J) = max(Ah(I,J), AhSm) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq @@ -1392,18 +1359,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%Re_Ah > 0.0) then do J=js-1,Jeq ; do I=is-1,Ieq KE = 0.125 * ((u(I,j,k) + u(I,j+1,k))**2 + (v(i,J,k) + v(i+1,J,k))**2) - Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(i,j) + Ah(I,J) = sqrt(KE) * CS%Re_Ah_const_xy(I,J) enddo ; enddo endif if (CS%better_bound_Ah) then if (CS%better_bound_Kh) then do J=js-1,Jeq ; do I=is-1,Ieq - Ah(I,J) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(I,J) * CS%Ah_Max_xy(I,J)) + Ah(I,J) = min(Ah(I,J), visc_bound_rem(I,J) * hrat_min(I,J) * CS%Ah_Max_xy(I,J)) enddo ; enddo else do J=js-1,Jeq ; do I=is-1,Ieq - Ah(I,J) = min(Ah(i,j), hrat_min(I,J) * CS%Ah_Max_xy(I,J)) + Ah(I,J) = min(Ah(I,J), hrat_min(I,J) * CS%Ah_Max_xy(I,J)) enddo ; enddo endif endif @@ -1426,52 +1393,42 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%use_GME) then - !### This call to get the 3-d GME diffusivity arrays and the subsequent blocking halo update - ! should occur outside of the k-loop, and perhaps the halo update should occur outside of - ! this routine altogether! - call thickness_diffuse_get_KH(TD, KH_u_GME, KH_v_GME, G, GV) - call pass_vector(KH_u_GME, KH_v_GME, G%Domain) - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + ! The wider halo here is to permit one pass of smoothing without a halo update. + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 GME_coeff = GME_effic_h(i,j) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I-1,j,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i,J-1,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if ((CS%id_GME_coeff_h>0) .or. find_FrictWork) GME_coeff_h(i,j,k) = GME_coeff str_xx_GME(i,j) = GME_coeff * sh_xx_bt(i,j) - enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq + ! The wider halo here is to permit one pass of smoothing without a halo update. + do J=js-2,je+1 ; do I=is-2,ie+1 GME_coeff = GME_effic_q(I,J) * 0.25 * & ((KH_u_GME(I,j,k)+KH_u_GME(I,j+1,k)) + (KH_v_GME(i,J,k)+KH_v_GME(i+1,J,k))) GME_coeff = MIN(GME_coeff, CS%GME_limiter) if (CS%id_GME_coeff_q>0) GME_coeff_q(I,J,k) = GME_coeff str_xy_GME(I,J) = GME_coeff * sh_xy_bt(I,J) - enddo ; enddo ! Applying GME diagonal term. This is linear and the arguments can be rescaled. - call smooth_GME(G, GME_flux_h=str_xx_GME) - call smooth_GME(G, GME_flux_q=str_xy_GME) + call smooth_GME(CS, G, GME_flux_h=str_xx_GME) + call smooth_GME(CS, G, GME_flux_q=str_xy_GME) - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - ! GME is applied below - if (CS%no_slip) then + ! GME is applied below + if (CS%no_slip) then + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * CS%reduction_xy(I,J)) - else + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) - endif - enddo ; enddo - - if (allocated(MEKE%GME_snk)) then - do j=js,je ; do i=is,ie - FrictWork_GME(i,j,k) = GME_coeff_h(i,j,k) * h(i,j,k) * GV%H_to_kg_m2 * grad_vel_mag_bt_h(i,j) enddo ; enddo endif @@ -1493,10 +1450,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h x.Div(h Grad u) or the biharmonic equivalent. do j=js,je ; do I=Isq,Ieq - diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j) *str_xx(i,j) - & - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & - G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - & - CS%dx2q(I,J) *str_xy(I,J))) * & + diffu(I,j,k) = ((G%IdyCu(I,j)*(CS%dy2h(i,j)*str_xx(i,j) - CS%dy2h(i+1,j)*str_xx(i+1,j)) + & + G%IdxCu(I,j)*(CS%dx2q(I,J-1)*str_xy(I,J-1) - CS%dx2q(I,J)*str_xy(I,J))) * & G%IareaCu(I,j)) / (h_u(I,j) + h_neglect) enddo ; enddo @@ -1515,10 +1470,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Evaluate 1/h y.Div(h Grad u) or the biharmonic equivalent. do J=Jsq,Jeq ; do i=is,ie - diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - & - CS%dy2q(I,J) *str_xy(I,J)) - & - G%IdxCv(i,J)*(CS%dx2h(i,j) *str_xx(i,j) - & - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & + diffv(i,J,k) = ((G%IdyCv(i,J)*(CS%dy2q(I-1,J)*str_xy(I-1,J) - CS%dy2q(I,J)*str_xy(I,J)) - & + G%IdxCv(i,J)*(CS%dx2h(i,j)*str_xx(i,j) - CS%dx2h(i,j+1)*str_xx(i,j+1))) * & G%IareaCv(i,J)) / (h_v(i,J) + h_neglect) enddo ; enddo @@ -1539,20 +1492,40 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Diagnose str_xx*d_x u - str_yy*d_y v + str_xy*(d_y u + d_x v) ! This is the old formulation that includes energy diffusion FrictWork(i,j,k) = GV%H_to_RZ * ( & - (str_xx(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & - -str_xx(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*((str_xy(I,J)*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +str_xy(I-1,J-1)*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +(str_xy(I-1,J)*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +str_xy(I,J-1)*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + (str_xx(i,j) * (u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - str_xx(i,j) * (v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) + enddo ; enddo ; endif + + if (CS%use_GME) then ; do j=js,je ; do i=is,ie + ! Diagnose str_xx_GME*d_x u - str_yy_GME*d_y v + str_xy_GME*(d_y u + d_x v) + ! This is the old formulation that includes energy diffusion + FrictWork_GME(i,j,k) = GV%H_to_RZ * ( & + (str_xx_GME(i,j)*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & + - str_xx_GME(i,j)*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & + + 0.25*((str_xy_GME(I,J) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J)) & + + str_xy_GME(I-1,J-1) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + (str_xy_GME(I-1,J) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + str_xy_GME(I,J-1) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo ; endif ! Make a similar calculation as for FrictWork above but accumulating into @@ -1597,18 +1570,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, MEKE%mom_src(i,j) = MEKE%mom_src(i,j) + GV%H_to_RZ * ( & ((str_xx(i,j)-RoScl*bhstr_xx(i,j))*(u(I,j,k)-u(I-1,j,k))*G%IdxT(i,j) & -(str_xx(i,j)-RoScl*bhstr_xx(i,j))*(v(i,J,k)-v(i,J-1,k))*G%IdyT(i,j)) & - +0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J))*( & - (u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & - +(v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & - +(str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1))*( & - (u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & - +(v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1) )) & - +((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J))*( & - (u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & - +(v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J) ) & - +(str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1))*( & - (u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & - +(v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1) )) ) ) + + 0.25*(((str_xy(I,J)-RoScl*bhstr_xy(I,J)) * & + ((u(I,j+1,k)-u(I,j,k))*G%IdyBu(I,J) & + + (v(i+1,J,k)-v(i,J,k))*G%IdxBu(I,J) ) & + + (str_xy(I-1,J-1)-RoScl*bhstr_xy(I-1,J-1)) * & + ((u(I-1,j,k)-u(I-1,j-1,k))*G%IdyBu(I-1,J-1) & + + (v(i,J-1,k)-v(i-1,J-1,k))*G%IdxBu(I-1,J-1)) ) & + + ((str_xy(I-1,J)-RoScl*bhstr_xy(I-1,J)) * & + ((u(I-1,j+1,k)-u(I-1,j,k))*G%IdyBu(I-1,J) & + + (v(i,J,k)-v(i-1,J,k))*G%IdxBu(I-1,J)) & + + (str_xy(I,J-1)-RoScl*bhstr_xy(I,J-1)) * & + ((u(I,j,k)-u(I,j-1,k))*G%IdyBu(I,J-1) & + + (v(i+1,J-1,k)-v(i,J-1,k))*G%IdxBu(I,J-1)) ) ) ) enddo ; enddo endif ! MEKE%backscatter_Ro_c @@ -1632,19 +1605,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffu>0) call post_data(CS%id_diffu, diffu, CS%diag) if (CS%id_diffv>0) call post_data(CS%id_diffv, diffv, CS%diag) if (CS%id_FrictWork>0) call post_data(CS%id_FrictWork, FrictWork, CS%diag) - if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) if (CS%id_Ah_h>0) call post_data(CS%id_Ah_h, Ah_h, CS%diag) if (CS%id_grid_Re_Ah>0) call post_data(CS%id_grid_Re_Ah, grid_Re_Ah, CS%diag) if (CS%id_div_xx_h>0) call post_data(CS%id_div_xx_h, div_xx_h, CS%diag) if (CS%id_vort_xy_q>0) call post_data(CS%id_vort_xy_q, vort_xy_q, CS%diag) - if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) - if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) + if (CS%id_sh_xx_h>0) call post_data(CS%id_sh_xx_h, sh_xx_h, CS%diag) + if (CS%id_sh_xy_q>0) call post_data(CS%id_sh_xy_q, sh_xy_q, CS%diag) if (CS%id_Ah_q>0) call post_data(CS%id_Ah_q, Ah_q, CS%diag) if (CS%id_Kh_h>0) call post_data(CS%id_Kh_h, Kh_h, CS%diag) if (CS%id_grid_Re_Kh>0) call post_data(CS%id_grid_Re_Kh, grid_Re_Kh, CS%diag) if (CS%id_Kh_q>0) call post_data(CS%id_Kh_q, Kh_q, CS%diag) - if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) - if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%use_GME) then ! post barotropic tension and strain + if (CS%id_GME_coeff_h > 0) call post_data(CS%id_GME_coeff_h, GME_coeff_h, CS%diag) + if (CS%id_GME_coeff_q > 0) call post_data(CS%id_GME_coeff_q, GME_coeff_q, CS%diag) + if (CS%id_FrictWork_GME>0) call post_data(CS%id_FrictWork_GME, FrictWork_GME, CS%diag) + if (CS%id_dudx_bt > 0) call post_data(CS%id_dudx_bt, dudx_bt, CS%diag) + if (CS%id_dvdy_bt > 0) call post_data(CS%id_dvdy_bt, dvdy_bt, CS%diag) + if (CS%id_dudy_bt > 0) call post_data(CS%id_dudy_bt, dudy_bt, CS%diag) + if (CS%id_dvdx_bt > 0) call post_data(CS%id_dvdx_bt, dvdx_bt, CS%diag) + endif if (CS%debug) then if (CS%Laplacian) then @@ -1818,11 +1797,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a Leith nonlinear eddy viscosity.", & default=.false., do_not_log=.not.CS%Laplacian) if (.not.CS%Laplacian) CS%Leith_Kh = .false. - ! This call duplicates one that occurs 26 lines later, and is probably unneccessary. - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%Modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.CS%Laplacian) !### (.not.CS%Leith_Kh)? + call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & + "The nondimensional Laplacian Leith constant, "//& + "often set to 1.0", units="nondim", default=0.0, & + fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) call get_param(param_file, mdl, "USE_MEKE", use_MEKE, & default=.false., do_not_log=.true.) call get_param(param_file, mdl, "RES_SCALE_MEKE_VISC", CS%res_scale_MEKE, & @@ -1831,27 +1809,6 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) do_not_log=.not.(CS%Laplacian.and.use_MEKE)) if (.not.(CS%Laplacian.and.use_MEKE)) CS%res_scale_MEKE = .false. - call get_param(param_file, mdl, "LEITH_LAP_CONST", Leith_Lap_const, & - "The nondimensional Laplacian Leith constant, "//& - "often set to 1.0", units="nondim", default=0.0, & - fail_if_missing=CS%Leith_Kh, do_not_log=.not.CS%Leith_Kh) - call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & - "If true, use QG Leith nonlinear eddy viscosity.", & - default=.false., do_not_log=.not.CS%Leith_Kh) - if (CS%use_QG_Leith_visc .and. .not. CS%Leith_Kh) call MOM_error(FATAL, & - "MOM_hor_visc.F90, hor_visc_init:"//& - "LEITH_KH must be True when USE_QG_LEITH_VISC=True.") - - !### The following two get_param_calls need to occur after Leith_Ah is read, but for now it replicates prior code. - CS%Leith_Ah = .false. - call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & - "If true, include the beta term in the Leith nonlinear eddy viscosity.", & - default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & - "If true, add a term to Leith viscosity which is "//& - "proportional to the gradient of divergence.", & - default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - call get_param(param_file, mdl, "BOUND_KH", CS%bound_Kh, & "If true, the Laplacian coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%Laplacian) @@ -1944,6 +1901,21 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "typically 0.015 - 0.06.", units="nondim", default=0.0, & fail_if_missing=CS%Smagorinsky_Ah, do_not_log=.not.CS%Smagorinsky_Ah) + call get_param(param_file, mdl, "USE_BETA_IN_LEITH", CS%use_beta_in_Leith, & + "If true, include the beta term in the Leith nonlinear eddy viscosity.", & + default=CS%Leith_Kh, do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "MODIFIED_LEITH", CS%modified_Leith, & + "If true, add a term to Leith viscosity which is "//& + "proportional to the gradient of divergence.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & + "If true, use QG Leith nonlinear eddy viscosity.", & + default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") + endif + call get_param(param_file, mdl, "BOUND_CORIOLIS", bound_Cor_def, default=.false.) call get_param(param_file, mdl, "BOUND_CORIOLIS_BIHARM", CS%bound_Coriolis, & "If true use a viscosity that increases with the square "//& @@ -1986,7 +1958,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_KH_BG_2D", CS%use_Kh_bg_2d, & "If true, read a file containing 2-d background harmonic "//& "viscosities. The final viscosity is the maximum of the other "//& - "terms and this background value.", default=.false.) ! ###do_not_log=.not.CS%Laplacian? + "terms and this background value.", default=.false., do_not_log=.not.CS%Laplacian) + if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false. call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & "If true, retain an answer-changing horizontal indexing bug in setting "//& "the corner-point viscosities when USE_KH_BG_2D=True. This is"//& @@ -1999,17 +1972,22 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "Use the split time stepping if true.", default=.true., do_not_log=.true.) if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") - call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & - "The strength of GME tapers quadratically to zero when the bathymetric "//& - "depth is shallower than GME_H0.", & - units="m", scale=US%m_to_Z, default=1000.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & - "The nondimensional prefactor multiplying the GME coefficient.", & - units="nondim", default=1.0, do_not_log=.not.CS%use_GME) - call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & - "The absolute maximum value the GME coefficient is allowed to take.", & - units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7, & - do_not_log=.not.CS%use_GME) + + if (CS%use_GME) then + call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, & + "Number of smoothing passes for the GME fluxes.", & + units="nondim", default=1) + call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & + "The strength of GME tapers quadratically to zero when the bathymetric "//& + "depth is shallower than GME_H0.", & + units="m", scale=US%m_to_Z, default=1000.0) + call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & + "The nondimensional prefactor multiplying the GME coefficient.", & + units="nondim", default=1.0) + call get_param(param_file, mdl, "GME_LIMITER", CS%GME_limiter, & + "The absolute maximum value the GME coefficient is allowed to take.", & + units="m2 s-1", scale=US%m_to_L**2*US%T_to_s, default=1.0e7) + endif if (CS%Laplacian .or. CS%biharmonic) then call get_param(param_file, mdl, "DT", dt, & @@ -2492,16 +2470,29 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%min_grid_Kh = spacing(1.) * min_grid_sp_h2 * Idt endif if (CS%use_GME) then - CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & + CS%id_dudx_bt = register_diag_field('ocean_model', 'dudx_bt', diag%axesT1, Time, & + 'Zonal component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dudy_bt = register_diag_field('ocean_model', 'dudy_bt', diag%axesB1, Time, & + 'Zonal component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdy_bt = register_diag_field('ocean_model', 'dvdy_bt', diag%axesT1, Time, & + 'Meridional component of the barotropic shearing strain at h points', 's-1', & + conversion=US%s_to_T) + CS%id_dvdx_bt = register_diag_field('ocean_model', 'dvdx_bt', diag%axesB1, Time, & + 'Meridional component of the barotropic shearing strain at q points', 's-1', & + conversion=US%s_to_T) + CS%id_GME_coeff_h = register_diag_field('ocean_model', 'GME_coeff_h', diag%axesTL, Time, & 'GME coefficient at h Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & + CS%id_GME_coeff_q = register_diag_field('ocean_model', 'GME_coeff_q', diag%axesBL, Time, & 'GME coefficient at q Points', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& - 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + CS%id_FrictWork_GME = register_diag_field('ocean_model','FrictWork_GME',diag%axesTL,Time,& + 'Integral work done by lateral friction terms in GME (excluding diffusion of energy)', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) endif CS%id_FrictWork = register_diag_field('ocean_model','FrictWork',diag%axesTL,Time,& - 'Integral work done by lateral friction terms', & + 'Integral work done by lateral friction terms. If GME is turned on, this '//& + 'includes the GME contribution.', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) CS%id_FrictWorkIntz = register_diag_field('ocean_model','FrictWorkIntz',diag%axesT1,Time, & 'Depth integrated work done by lateral friction', & @@ -2531,7 +2522,8 @@ end subroutine align_aniso_tensor_to_grid !> Apply a 1-1-4-1-1 Laplacian filter one time on GME diffusive flux to reduce any !! horizontal two-grid-point noise -subroutine smooth_GME(G, GME_flux_h, GME_flux_q) +subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) + 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) :: GME_flux_h!< GME diffusive flux !! at h points @@ -2541,57 +2533,62 @@ subroutine smooth_GME(G, GME_flux_h, GME_flux_q) real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original real :: wc, ww, we, wn, ws ! averaging weights for smoothing - integer :: i, j, k, s - do s=1,1 - ! Update halos + integer :: i, j, s, halosz + integer :: xh, xq ! The number of valid extra halo points for h and q points. + 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 + xh = 0 ; xq = 0 + + do s=1,CS%num_smooth_gme if (present(GME_flux_h)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_h, G%Domain) + if (xh < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_h, G%Domain, halo=halosz) + xh = halosz - 2 + endif GME_flux_h_original(:,:) = GME_flux_h(:,:) ! apply smoothing on GME - do j = G%jsc, G%jec - do i = G%isc, G%iec - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dT(i-1,j) - we = 0.125 * G%mask2dT(i+1,j) - ws = 0.125 * G%mask2dT(i,j-1) - wn = 0.125 * G%mask2dT(i,j+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. - GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & - + ww * GME_flux_h_original(i-1,j) & - + we * GME_flux_h_original(i+1,j) & - + ws * GME_flux_h_original(i,j-1) & - + wn * GME_flux_h_original(i,j+1) - enddo - enddo + do j=Jsq-xh,Jeq+1+xh ; do i=Isq-xh,Ieq+1+xh + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dT(i-1,j) + we = 0.125 * G%mask2dT(i+1,j) + ws = 0.125 * G%mask2dT(i,j-1) + wn = 0.125 * G%mask2dT(i,j+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_h(i,j) = wc * GME_flux_h_original(i,j) & + + ((ww * GME_flux_h_original(i-1,j) + we * GME_flux_h_original(i+1,j)) & + + (ws * GME_flux_h_original(i,j-1) + wn * GME_flux_h_original(i,j+1))) + enddo ; enddo + xh = xh - 1 endif - ! Update halos if (present(GME_flux_q)) then - !### Work on a wider halo to eliminate this blocking send! - call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true.) + if (xq < 0) then + ! Update halos if needed, but avoid doing so more often than is needed. + halosz = min(G%isc-G%isd, G%jsc-G%jsd, 2+CS%num_smooth_gme-s) + call pass_var(GME_flux_q, G%Domain, position=CORNER, complete=.true., halo=halosz) + xq = halosz - 2 + endif GME_flux_q_original(:,:) = GME_flux_q(:,:) ! apply smoothing on GME - do J = G%JscB, G%JecB - do I = G%IscB, G%IecB - ! skip land points - if (G%mask2dBu(I,J)==0.) cycle - ! compute weights - ww = 0.125 * G%mask2dBu(I-1,J) - we = 0.125 * G%mask2dBu(I+1,J) - ws = 0.125 * G%mask2dBu(I,J-1) - wn = 0.125 * G%mask2dBu(I,J+1) - wc = 1.0 - (ww+we+wn+ws) - !### Add parentheses to make this rotationally invariant. - GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & - + ww * GME_flux_q_original(I-1,J) & - + we * GME_flux_q_original(I+1,J) & - + ws * GME_flux_q_original(I,J-1) & - + wn * GME_flux_q_original(I,J+1) - enddo - enddo + do J=js-1-xq,je+xq ; do I=is-1-xq,ie+xq + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute weights + ww = 0.125 * G%mask2dBu(I-1,J) + we = 0.125 * G%mask2dBu(I+1,J) + ws = 0.125 * G%mask2dBu(I,J-1) + wn = 0.125 * G%mask2dBu(I,J+1) + wc = 1.0 - ((ww+we)+(wn+ws)) + GME_flux_q(I,J) = wc * GME_flux_q_original(I,J) & + + ((ww * GME_flux_q_original(I-1,J) + we * GME_flux_q_original(I+1,J)) & + + (ws * GME_flux_q_original(I,J-1) + wn * GME_flux_q_original(I,J+1))) + enddo ; enddo + xq = xq - 1 endif enddo ! s-loop end subroutine smooth_GME diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dfbb3e0d63..b152583269 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,17 +16,15 @@ 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_io, only : slasher, vardesc, MOM_read_data, file_exists +use MOM_io, only : slasher, MOM_read_data, file_exists use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart -use MOM_spatial_means, only : global_area_mean +use MOM_spatial_means, only : global_area_integral 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 use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_structure, only: wave_structure_init, wave_structure, wave_structure_CS -!use, intrinsic :: IEEE_ARITHMETIC - implicit none ; private #include @@ -52,11 +50,11 @@ module MOM_internal_tides logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. real, allocatable, dimension(:,:) :: refl_angle - !< local coastline/ridge/shelf angles read from file + !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) - real :: nullangle = -999.9 !< placeholder value in cells with no reflection + real :: nullangle = -999.9 !< placeholder value in cells with no reflection [rad] real, allocatable, dimension(:,:) :: refl_pref - !< partial reflection coeff for each "coast cell" + !< partial reflection coeff for each "coast cell" [nondim] ! (could be in G control structure) logical, allocatable, dimension(:,:) :: refl_pref_logical !< true if reflecting cell with partial reflection @@ -65,6 +63,10 @@ module MOM_internal_tides !< identifies reflection cells where double reflection !! is possible (i.e. ridge cells) ! (could be in G control structure) + real, allocatable, dimension(:,:) :: trans + !< partial transmission coeff for each "coast cell" + real, allocatable, dimension(:,:) :: residual + !< residual of reflection and transmission coeff for each "coast cell" real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss @@ -79,6 +81,8 @@ module MOM_internal_tides !! the energy losses in [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss + !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, @@ -87,14 +91,16 @@ module MOM_internal_tides !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_Froude_loss !< Energy loss rates due to wave breaking, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] + real, allocatable, dimension(:,:) :: tot_residual_loss !< Energy loss rates due to residual on slopes, + !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_allprocesses_loss !< Energy loss rates due to all processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real :: q_itides !< fraction of local dissipation [nondim] - real :: En_sum !< global sum of energy for use in debugging [R Z3 T-2 ~> J m-2] + real :: En_sum !< global sum of energy for use in debugging, in MKS units [J] type(time_type), pointer :: Time => NULL() !< A pointer to the model's clock. character(len=200) :: inputdir !< directory to look for coastline angle file real :: decay_rate !< A constant rate at which internal tide energy is - !! lost to the interior ocean internal wave field. + !! lost to the interior ocean internal wave field [T-1 ~> s-1]. real :: cdrag !< The bottom drag coefficient [nondim]. real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when @@ -107,6 +113,8 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. + logical :: apply_residual_drag + !< If true, apply sink from residual term of reflection/transmission. real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] @@ -122,10 +130,11 @@ module MOM_internal_tides ! Diag handles relevant to all modes, frequencies, and angles integer :: id_tot_En = -1, id_TKE_itidal_input = -1, id_itide_drag = -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 ! Diag handles considering: sums over all modes, frequencies, and angles integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 - integer :: id_tot_Froude_loss = -1, id_tot_allprocesses_loss = -1 + integer :: id_tot_Froude_loss = -1, id_tot_residual_loss = -1, id_tot_allprocesses_loss = -1 ! Diag handles considering: all modes & freqs; summed over angles integer, allocatable, dimension(:,:) :: & id_En_mode, & @@ -179,12 +188,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & 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),SZJB_(G)) :: & - flux_heat_y, & - flux_prec_y real, dimension(SZI_(G),SZJ_(G)) :: & 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_allprocesses_loss, & + 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] @@ -198,6 +204,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real :: loss_rate ! An energy loss rate [T-1 ~> s-1] real :: Fr2_max real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] + real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] @@ -211,7 +218,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nAngle = CS%NAngle I_rho0 = 1.0 / GV%Rho0 - cn_subRO = 1e-100*US%m_s_to_L_T ! The hard-coded value here might need to increase. + cn_subRO = 1e-30*US%m_s_to_L_T + en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T ! init local arrays drag_scale(:,:) = 0. @@ -286,8 +294,11 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Propagate the waves. do m=1,CS%NMode ; do fr=1,CS%Nfreq + + CS%TKE_residual_loss(:,:,:,fr,m) = 0. + call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & - G, US, CS, CS%NAngle) + G, US, CS, CS%NAngle, CS%TKE_residual_loss(:,:,:,fr,m)) enddo ; enddo ! Check for En<0 - for debugging, delete later @@ -502,9 +513,26 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & enddo ; enddo enddo ; enddo ; enddo + ! loss from residual of reflection/transmission coefficients + if (CS%apply_residual_drag) then + + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + ! implicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & + ! (CS%En(i,j,a,fr,m) + en_subRO)) + ! rewritten to minimize number of divisions: + CS%En(i,j,a,fr,m) = (CS%En(i,j,a,fr,m) * (CS%En(i,j,a,fr,m) + en_subRO)) / & + ((CS%En(i,j,a,fr,m) + en_subRO) + dt * CS%TKE_residual_loss(i,j,a,fr,m)) + + ! explicit form + !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) - dt * CS%TKE_residual_loss(i,j,a,fr,m) + enddo ; enddo ; enddo ; enddo ; enddo + endif + + ! Check for energy conservation on computational domain.************************* do m=1,CS%NMode ; do fr=1,CS%Nfreq - call sum_En(G,CS,CS%En(:,:,:,fr,m),'prop_int_tide') + call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') enddo ; enddo ! Output diagnostics.************************************************************ @@ -537,21 +565,25 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & tot_quad_loss(:,:) = 0.0 tot_itidal_loss(:,:) = 0.0 tot_Froude_loss(:,:) = 0.0 + tot_residual_loss(:,:) = 0.0 tot_allprocesses_loss(:,:) = 0.0 do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) tot_Froude_loss(i,j) = tot_Froude_loss(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + tot_residual_loss(i,j) = tot_residual_loss(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) enddo ; enddo ; enddo ; enddo ; enddo do j=js,je ; do i=is,ie - tot_allprocesses_loss(i,j) = tot_leak_loss(i,j) + tot_quad_loss(i,j) + & - tot_itidal_loss(i,j) + tot_Froude_loss(i,j) + tot_allprocesses_loss(i,j) = ((((tot_leak_loss(i,j) + tot_quad_loss(i,j)) + & + tot_itidal_loss(i,j)) + tot_Froude_loss(i,j)) + & + tot_residual_loss(i,j)) enddo ; enddo CS%tot_leak_loss = tot_leak_loss CS%tot_quad_loss = tot_quad_loss CS%tot_itidal_loss = tot_itidal_loss CS%tot_Froude_loss = tot_Froude_loss + CS%tot_residual_loss = tot_residual_loss CS%tot_allprocesses_loss = tot_allprocesses_loss if (CS%id_tot_leak_loss > 0) then call post_data(CS%id_tot_leak_loss, tot_leak_loss, CS%diag) @@ -565,6 +597,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%id_tot_Froude_loss > 0) then call post_data(CS%id_tot_Froude_loss, tot_Froude_loss, CS%diag) endif + if (CS%id_tot_residual_loss > 0) then + call post_data(CS%id_tot_residual_loss, tot_residual_loss, CS%diag) + endif if (CS%id_tot_allprocesses_loss > 0) then call post_data(CS%id_tot_allprocesses_loss, tot_allprocesses_loss, CS%diag) endif @@ -577,8 +612,9 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & 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) 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_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_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) @@ -606,25 +642,23 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & end subroutine propagate_int_tide !> Checks for energy conservation on computational domain -subroutine sum_En(G, CS, En, label) +subroutine sum_En(G, US, CS, En, label) 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(int_tide_CS), intent(inout) :: CS !< Internal tide control struct real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages ! Local variables - real :: En_sum ! The total energy [R Z3 T-2 ~> J m-2] - real :: tmpForSumming - integer :: m,fr,a + real :: En_sum ! The total energy in MKS units for potential output [J] + integer :: a ! real :: En_sum_diff, En_sum_pdiff ! character(len=160) :: mesg ! The text of an error message ! real :: days En_sum = 0.0 - tmpForSumming = 0.0 do a=1,CS%nAngle - tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global - En_sum = En_sum + tmpForSumming + En_sum = En_sum + global_area_integral(En(:,:,a), G, scale=US%RZ3_T3_to_W_m2*US%T_to_s) enddo CS%En_sum = En_sum !En_sum_diff = En_sum - CS%En_sum @@ -671,7 +705,6 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, integer :: j,i,m,fr,a, is, ie, js, je real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] - real :: TKE_sum_check ! temporary for check summing real :: frac_per_sector ! fraction of energy in each wedge real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is ! assumed to stay in propagating mode for now - BDM) @@ -920,7 +953,6 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) real :: I_Angle_size ! The inverse of the the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] - real :: dMx, dMn real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular ! orientation [R Z3 T-2 rad-1 ~> J m-2 rad-1] real :: dA, curv_3 ! Difference and curvature of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] @@ -992,7 +1024,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) end subroutine PPM_angular_advect !> Propagates internal waves at a single frequency. -subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) +subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1006,7 +1038,9 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct - + real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & speed ! The magnitude of the group velocity at the q points for corner adv [L T-1 ~> m s-1]. @@ -1056,7 +1090,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) speed(:,:) = 0.0 do J=jsh-1,jeh ; do I=ish-1,ieh f2 = G%CoriolisBu(I,J)**2 - speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & + speed(I,J) = 0.25*((cn(i,j) + cn(i+1,j+1)) + (cn(i+1,j) + cn(i,j+1))) * & sqrt(max(freq2 - f2, 0.0)) * Ifreq enddo ; enddo do a=1,na @@ -1097,21 +1131,22 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle) ! Apply propagation in x-direction (reflection included) LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB) + call propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_x') + !call sum_En(G, US, CS, En, 'post-propagate_x') ! Update halos call pass_var(En, G%domain) + call pass_var(residual_loss, G%domain) ! Apply propagation in y-direction (reflection included) ! LB%jsh = js ; LB%jeh = je ; LB%ish = is ; LB%ieh = ie ! Use if no teleport LB%jsh = jsh ; LB%jeh = jeh ; LB%ish = ish ; LB%ieh = ieh - call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB) + call propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, CS%nAngle, CS, LB, residual_loss) ! Check for energy conservation on computational domain (for debugging) - !call sum_En(G, CS, En, 'post-propagate_y') + !call sum_En(G, US, CS, En, 'post-propagate_y') endif end subroutine propagate @@ -1134,7 +1169,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables - integer :: i, j, k, ish, ieh, jsh, jeh, m + integer :: i, j, ish, ieh, jsh, jeh, m real :: TwoPi, Angle_size real :: energized_angle ! angle through center of current wedge real :: theta ! angle at edge of wedge @@ -1151,7 +1186,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real :: slopeN,slopeW,slopeS,slopeE, bN,bW,bS,bE ! parameters defining parcel sides real :: aNE,aN,aNW,aW,aSW,aS,aSE,aE,aC ! sub-areas of advected parcel real :: a_total ! total area of advected parcel - real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel + ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x,y ! coordinates of cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx,Idy ! inverse of dx,dy at cell corners real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx,dy ! dx,dy at cell corners @@ -1178,7 +1213,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS do j=jsh,jeh ; do i=ish,ieh do m=1,int(Nsubrays) - theta = energized_angle - 0.5*Angle_size + real(m - 1)*Angle_size*I_Nsubwedges + theta = (energized_angle - 0.5*Angle_size) + real(m - 1)*Angle_size*I_Nsubwedges if (theta < 0.0) then theta = theta + TwoPi elseif (theta > TwoPi) then @@ -1268,114 +1303,133 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS if (0.0 <= theta .and. theta < 0.25*TwoPi) then xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) ! west area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aW = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! southwest area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aSW = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aSW = a1 + a2 + a3 + a4 + aSW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! south area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aS = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! area within cell - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aC = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then xCrn = x(I,J-1); yCrn = y(I,J-1) ! south area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aS = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aS = a1 + a2 + a3 + a4 + aS = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! southeast area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aSE = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aSE = a1 + a2 + a3 + a4 + aSE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! east area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aE = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! area within cell - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aC = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then xCrn = x(I,J); yCrn = y(I,J) ! east area - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aE = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aE = a1 + a2 + a3 + a4 + aE = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) ! northeast area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aNE = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aNE = a1 + a2 + a3 + a4 + aNE = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! north area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aN = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! area within cell - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aC = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then xCrn = x(I-1,J); yCrn = y(I-1,J) ! north area - a1 = (yNE - yE)*(0.5*(xNE + xE)) - a2 = (yE - yCrn)*(0.5*(xE + xCrn)) - a3 = (yCrn - yN)*(0.5*(xCrn + xN)) - a4 = (yN - yNE)*(0.5*(xN + xNE)) - aN = a1 + a2 + a3 + a4 + !a1 = (yNE - yE)*(0.5*(xNE + xE)) + !a2 = (yE - yCrn)*(0.5*(xE + xCrn)) + !a3 = (yCrn - yN)*(0.5*(xCrn + xN)) + !a4 = (yN - yNE)*(0.5*(xN + xNE)) + !aN = a1 + a2 + a3 + a4 + aN = 0.5 * ((yCrn - yNE)*(xN - xE) + (xCrn - xNE)*(yE - yN)) ! northwest area - a1 = (yN - yCrn)*(0.5*(xN + xCrn)) - a2 = (yCrn - yW)*(0.5*(xCrn + xW)) - a3 = (yW - yNW)*(0.5*(xW + xNW)) - a4 = (yNW - yN)*(0.5*(xNW + xN)) - aNW = a1 + a2 + a3 + a4 + !a1 = (yN - yCrn)*(0.5*(xN + xCrn)) + !a2 = (yCrn - yW)*(0.5*(xCrn + xW)) + !a3 = (yW - yNW)*(0.5*(xW + xNW)) + !a4 = (yNW - yN)*(0.5*(xNW + xN)) + !aNW = a1 + a2 + a3 + a4 + aNW = 0.5 * ((yCrn - yNW)*(xW - xN) + (xCrn - xNW)*(yN - yW)) ! west area - a1 = (yCrn - yS)*(0.5*(xCrn + xS)) - a2 = (yS - ySW)*(0.5*(xS + xSW)) - a3 = (ySW - yW)*(0.5*(xSW + xW)) - a4 = (yW - yCrn)*(0.5*(xW + xCrn)) - aW = a1 + a2 + a3 + a4 + !a1 = (yCrn - yS)*(0.5*(xCrn + xS)) + !a2 = (yS - ySW)*(0.5*(xS + xSW)) + !a3 = (ySW - yW)*(0.5*(xSW + xW)) + !a4 = (yW - yCrn)*(0.5*(xW + xCrn)) + !aW = a1 + a2 + a3 + a4 + aW = 0.5 * ((yCrn - ySW)*(xS - xW) + (xCrn - xSW)*(yW - yS)) ! area within cell - a1 = (yE - ySE)*(0.5*(xE + xSE)) - a2 = (ySE - yS)*(0.5*(xSE + xS)) - a3 = (yS - yCrn)*(0.5*(xS + xCrn)) - a4 = (yCrn - yE)*(0.5*(xCrn + xE)) - aC = a1 + a2 + a3 + a4 + !a1 = (yE - ySE)*(0.5*(xE + xSE)) + !a2 = (ySE - yS)*(0.5*(xSE + xS)) + !a3 = (yS - yCrn)*(0.5*(xS + xCrn)) + !a4 = (yCrn - yE)*(0.5*(xCrn + xE)) + !aC = a1 + a2 + a3 + a4 + aC = 0.5 * ((yCrn - ySE)*(xE - xS) + (xCrn - xSE)*(yS - yE)) endif ! energy weighting ---------------------------------------- - a_total = aNE + aN + aNW + aW + aSW + aS + aSE + aE + aC - E_new(m) = (aNE*En(i+1,j+1) + aN*En(i,j+1) + aNW*En(i-1,j+1) + & - aW*En(i-1,j) + aSW*En(i-1,j-1) + aS*En(i,j-1) + & - aSE*En(i+1,j-1) + aE*En(i+1,j) + aC*En(i,j)) / (dx(i,j)*dy(i,j)) + a_total = (((aNE + aSW) + (aNW + aSE)) + ((aN + aS) + (aW + aE))) + aC + + E_new(m) = ( ( ( ( aNE*En(i+1,j+1) + aSW*En(i-1,j-1) ) + & + ( aNW*En(i-1,j+1) + aSE*En(i+1,j-1) ) ) + & + ( ( aN*En(i,j+1) + aS*En(i,j-1) ) + & + ( aW*En(i-1,j) + aE*En(i+1,j) ) ) ) + & + aC*En(i,j) ) / ( dx(i,j)*dy(i,j) ) enddo ! m-loop ! update energy in cell En(i,j) = sum(E_new)/Nsubrays @@ -1383,7 +1437,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS end subroutine propagate_corner_spread !> Propagates the internal wave energy in the logical x-direction. -subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) +subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, residual_loss) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1400,17 +1454,20 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! Left and right face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZIB_(G),SZJ_(G)) :: & flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. real, dimension(SZIB_(G)) :: & - cg_p, cg_m, flux1, flux2 + cg_p, flux1 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] - integer :: i, j, k, ish, ieh, jsh, jeh, a + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1436,6 +1493,10 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_x(I-1,j) ! left face influx [R Z3 L2 T-2 ~> J] Fdt_p(i,j,a) = -dt*flux_x(I,j) ! right face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_x(I-1,j)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_x(I,j)) * CS%residual(i,j) * G%IareaT(i,j)) enddo ; enddo enddo ! a-loop @@ -1457,7 +1518,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB) end subroutine propagate_x !> Propagates the internal wave energy in the logical y-direction. -subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) +subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, residual_loss) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. @@ -1474,18 +1535,19 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & + intent(inout) :: residual_loss !< internal tide energy loss due + !! to the residual at slopes [R Z3 T-3 ~> W m-2]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. - real, dimension(SZI_(G)) :: & - cg_p, cg_m, flux1, flux2 + real, dimension(SZI_(G)) :: cg_p, flux1 !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] - character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, ish, ieh, jsh, jeh, a + integer :: i, j, ish, ieh, jsh, jeh, a ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh do a=1,Nangle @@ -1511,6 +1573,11 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx [R Z3 L2 T-2 ~> J] Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx [R Z3 L2 T-2 ~> J] + + residual_loss(i,j,a) = residual_loss(i,j,a) + & + (abs(flux_y(i,J-1)) * CS%residual(i,j) * G%IareaT(i,j) + & + abs(flux_y(i,J)) * CS%residual(i,j) * G%IareaT(i,j)) + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0) then ! for debugging ! call MOM_error(WARNING, "propagate_y: OutFlux>Available prior to reflection", .true.) ! write(mesg,*) "flux_y_south=",flux_y(i,J-1),"flux_y_north=",flux_y(i,J),"En=",En(i,j,a), & @@ -1608,13 +1675,13 @@ subroutine merid_flux_En(v, h, hL, hR, vh, dt, G, US, J, ish, ieh, vol_CFL) if (v(i) > 0.0) then if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif - curv_3 = hL(i,j) + hR(i,j) - 2.0*h(i,j) + curv_3 = (hL(i,j) + hR(i,j)) - 2.0*h(i,j) vh(i) = G%dx_Cv(i,J) * v(i) * ( hR(i,j) + CFL * & (0.5*(hL(i,j) - hR(i,j)) + curv_3*(CFL - 1.5)) ) elseif (v(i) < 0.0) then if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif - curv_3 = hL(i,j+1) + hR(i,j+1) - 2.0*h(i,j+1) + curv_3 = (hL(i,j+1) + hR(i,j+1)) - 2.0*h(i,j+1) vh(i) = G%dx_Cv(i,J) * v(i) * ( hL(i,j+1) + CFL * & (0.5*(hR(i,j+1)-hL(i,j+1)) + curv_3*(CFL - 1.5)) ) else @@ -1634,6 +1701,7 @@ subroutine reflect(En, NAngle, CS, G, LB) !! [R Z3 T-2 ~> J m-2]. type(int_tide_CS), intent(in) :: CS !< Internal tide control struct type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. + ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c ! angle of boundary wrt equator [rad] @@ -1646,13 +1714,13 @@ subroutine reflect(En, NAngle, CS, G, LB) real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] - integer :: angle_wall ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_wall0 ! angle of coast/ridge/shelf wrt equator [nondim] - integer :: angle_r ! angle of reflected ray wrt equator [nondim] - integer :: angle_r0 ! angle of reflected ray wrt equator [nondim] - integer :: angle_to_wall ! angle relative to wall [nondim] + integer :: angle_wall ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_wall0 ! angle-bin of coast/ridge/shelf wrt equator + integer :: angle_r ! angle-bin of reflected ray wrt equator + integer :: angle_r0 ! angle-bin of reflected ray wrt equator + integer :: angle_to_wall ! angle-bin relative to wall integer :: a, a0 ! loop index for angles - integer :: i, j, i_global + integer :: i, j integer :: Nangle_d2 ! Nangle / 2 integer :: isc, iec, jsc, jec ! start and end local indices on PE ! (values exclude halos) @@ -1692,12 +1760,12 @@ subroutine reflect(En, NAngle, CS, G, LB) angle_wall0 = angle_wall - 1 ! compute relative angle from wall and use cyclic properties ! to ensure it is bounded by 0 -> Nangle-1 - angle_to_wall = mod(a0 - angle_wall0 + Nangle, Nangle) + angle_to_wall = mod((a0 - angle_wall0) + Nangle, Nangle) if (ridge(i,j)) then ! if ray is not incident but in ridge cell, use complementary angle if ((Nangle_d2 < angle_to_wall) .and. (angle_to_wall < Nangle)) then - angle_wall0 = mod(angle_wall0 + Nangle_d2 + Nangle, Nangle) + angle_wall0 = mod(angle_wall0 + (Nangle_d2 + Nangle), Nangle) endif endif @@ -1902,7 +1970,6 @@ subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) real, parameter :: oneSixth = 1./6. real :: h_ip1, h_im1 real :: dMx, dMn - logical :: use_CW84 character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2051,13 +2118,12 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) integer, intent(in) :: jie !< End j-index for computations ! Local variables real :: curv, dh, scale - character(len=256) :: mesg ! The text of an error message integer :: i,j do j=jis,jie ; do i=iis,iie ! This limiter prevents undershooting minima within the domain with ! values less than h_min. - curv = 3.0*(h_L(i,j) + h_R(i,j) - 2.0*h_in(i,j)) + curv = 3.0*((h_L(i,j) + h_R(i,j)) - 2.0*h_in(i,j)) if (curv > 0.0) then ! Only minima are limited. dh = h_R(i,j) - h_L(i,j) if (abs(dh) < curv) then ! The parabola's minimum is within the cell. @@ -2086,7 +2152,6 @@ end subroutine PPM_limit_pos ! ! This subroutine is used to allocate and register any fields in this module ! ! that should be written to or read from the restart file. ! logical :: use_int_tides -! type(vardesc) :: vd ! integer :: num_freq, num_angle , num_mode, period_1 ! integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, a ! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2108,10 +2173,9 @@ end subroutine PPM_limit_pos ! call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) ! allocate(CS%En_restart(isd:ied, jsd:jed, num_angle), source=0.0) -! vd = vardesc("En_restart", & -! "The internal wave energy density as a function of (i,j,angle,frequency,mode)", & -! 'h','1','1',"J m-2") -! call register_restart_field(CS%En_restart, vd, .false., restart_CS) +! call register_restart_field(CS%En_restart, "En_restart", .false., restart_CS, & +! longname="The internal wave energy density as a function of (i,j,angle,frequency,mode)", & +! units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1') ! end subroutine register_int_tide_restarts @@ -2149,10 +2213,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: var_name character(len=160) :: var_descript character(len=200) :: filename - character(len=200) :: refl_angle_file, land_mask_file - character(len=200) :: refl_pref_file, refl_dbl_file - character(len=200) :: dy_Cu_file, dx_Cv_file + character(len=200) :: refl_angle_file + character(len=200) :: refl_pref_file, refl_dbl_file, trans_file character(len=200) :: h2_file + !character(len=200) :: land_mask_file + !character(len=200) :: dy_Cu_file, dx_Cv_file isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2269,6 +2334,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_WAVE_DRAG", CS%apply_wave_drag, & "If true, apply scattering due to small-scale roughness as a sink.", & default=.false.) + call get_param(param_file, mdl, "INTERNAL_TIDE_RESIDUAL_DRAG", CS%apply_residual_drag, & + "If true, TBD", & + default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& "of the quadratic drag terms for internal tides.", & @@ -2307,10 +2375,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%TKE_quad_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_itidal_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%TKE_Froude_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) + allocate(CS%TKE_residual_loss(isd:ied,jsd:jed,num_angle,num_freq,num_mode), source=0.0) allocate(CS%tot_leak_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_quad_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_itidal_loss(isd:ied,jsd:jed), source=0.0) allocate(CS%tot_Froude_loss(isd:ied,jsd:jed), source=0.0) + allocate(CS%tot_residual_loss(isd:ied,jsd:jed), source=0.0) ! Compute the fixed part of the bottom drag loss from baroclinic modes call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -2406,6 +2476,32 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) else ; CS%refl_dbl(i,j) = .false. ; endif enddo ; enddo + ! Read in the transmission coefficient and infer the residual + call get_param(param_file, mdl, "TRANS_FILE", trans_file, & + "The path to the file containing the transmission coefficent for internal tides.", & + fail_if_missing=.false., default='') + filename = trim(CS%inputdir) // trim(trans_file) + allocate(CS%trans(isd:ied,jsd:jed), source=0.0) + if (file_exists(filename, G%domain)) then + call log_param(param_file, mdl, "INPUTDIR/TRANS_FILE", filename) + call MOM_read_data(filename, 'trans', CS%trans, G%domain) + else + if (trim(trans_file) /= '' ) call MOM_error(FATAL, & + "TRANS_FILE: "//trim(filename)//" not found") + endif + + call pass_var(CS%trans,G%domain) + ! residual + allocate(CS%residual(isd:ied,jsd:jed), source=0.0) + do j=jsd,jed + do i=isd,ied + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) + endif + enddo + enddo + call pass_var(CS%residual,G%domain) + ! Read in prescribed land mask from file (if overwriting -BDM). ! This should be done in MOM_initialize_topography subroutine ! defined in MOM_fixed_initialization.F90 (BDM) @@ -2445,6 +2541,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Time, 'Local angle of coastline/ridge/shelf with respect to equator', 'rad') CS%id_refl_pref = register_diag_field('ocean_model', 'refl_pref', diag%axesT1, & Time, 'Partial reflection coefficients', '') + CS%id_trans = register_diag_field('ocean_model', 'trans', diag%axesT1, & + Time, 'Partial transmission coefficients', '') + CS%id_residual = register_diag_field('ocean_model', 'residual', diag%axesT1, & + Time, 'Residual of reflection and transmission coefficients', '') CS%id_dx_Cv = register_diag_field('ocean_model', 'dx_Cv', diag%axesT1, & Time, 'North face unblocked width', 'm', conversion=US%L_to_m) CS%id_dy_Cu = register_diag_field('ocean_model', 'dy_Cu', diag%axesT1, & @@ -2454,6 +2554,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) ! Output reflection parameters as diags here (not needed every timestep) if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) + if (CS%id_trans > 0) call post_data(CS%id_trans, CS%trans, CS%diag) + if (CS%id_residual > 0) call post_data(CS%id_residual, CS%residual, CS%diag) if (CS%id_dx_Cv > 0) call post_data(CS%id_dx_Cv, G%dx_Cv, CS%diag) if (CS%id_dy_Cu > 0) call post_data(CS%id_dy_Cu, G%dy_Cu, CS%diag) if (CS%id_land_mask > 0) call post_data(CS%id_land_mask, G%mask2dT, CS%diag) @@ -2483,6 +2585,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_tot_Froude_loss = register_diag_field('ocean_model', 'ITide_tot_Froude_loss', diag%axesT1, & Time, 'Internal tide energy loss to wave breaking', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) + CS%id_tot_residual_loss = register_diag_field('ocean_model', 'ITide_tot_residual_loss', diag%axesT1, & + Time, 'Internal tide energy loss to residual on slopes', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_tot_allprocesses_loss = register_diag_field('ocean_model', 'ITide_tot_allprocesses_loss', diag%axesT1, & Time, 'Internal tide energy loss summed over all processes', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index da8e936642..88e1c772a2 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -216,7 +216,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) real :: dx_term ! A term in the denominator [L2 T-2 ~> m2 s-2] or [m2 s-2] integer :: power_2 integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: i, j, k + integer :: i, j 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 @@ -526,7 +526,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max + integer :: i, j, k integer :: l_seg real :: S2max, wNE, wSE, wSW, wNW real :: H_u(SZIB_(G)), H_v(SZI_(G)) @@ -876,7 +876,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. integer :: is, ie, js, je, nz - integer :: i, j, k, kb_max + integer :: i, j, k integer :: l_seg real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(GV)) real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(GV)) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 04982d7171..e1dff4f5bd 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -13,12 +13,11 @@ module MOM_mixed_layer_restrat use MOM_forcing_type, only : mech_forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_EOS, only : calculate_density, EOS_domain implicit none ; private @@ -156,15 +155,16 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: Ihtot,Ihtot_slow! Inverses of the total mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux ! magnitudes (uDml & vDml) to the realized flux in a - ! layer. The vertical sum of a() through the pieces of + ! layer [nondim]. The vertical sum of a() through the pieces of ! the mixed layer must be 0. - real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD + real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD [nondim] real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. real :: uDml_slow(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper @@ -172,32 +172,29 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales in the zonal and real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays ! for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: rhoAtK, rho1, d1, pRef_N2 ! Used for N2 real :: aFac, bFac ! Nondimensional ratios [nondim] - real :: ddRho ! A density difference [R ~> kg m-3] - real :: hAtVel, zpa, zpb, dh, res_scaling_fac + real :: ddRho ! A density difference [R ~> kg m-3] + real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] + real :: zpa ! Fractional position within the mixed layer of the interface above a layer [nondim] + real :: zpb ! Fractional position within the mixed layer of the interface below a layer [nondim] + real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] + real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real :: PSI, PSI1, z, BOTTOP, XP, DD ! For the following statement functions - ! Stream function as a function of non-dimensional position within mixed-layer (F77 statement function) - !PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) ) - PSI1(z) = max(0., (1. - (2.*z+1.)**2 ) * (1. + (5./21.)*(2.*z+1.)**2) ) - BOTTOP(z) = 0.5*(1.-SIGN(1.,z+0.5)) ! =0 for z>-0.5, =1 for z<-0.5 - XP(z) = max(0., min(1., (-z-0.5)*2./(1.+2.*CS%MLE_tail_dh) ) ) - DD(z) = (1.-3.*(XP(z)**2)+2.*(XP(z)**3))**(1.+2.*CS%MLE_tail_dh) - PSI(z) = max( PSI1(z), DD(z)*BOTTOP(z) ) ! Combines original PSI1 with tail - 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_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & @@ -299,16 +296,11 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot_fast,Rml_av_fast,tv,p0,h,h_avail,& -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr,EOSdom, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP htot_slow,MLD_slow,Rml_av_slow,VarMix,I_LFront, & -!$OMP res_upscale, nz,MLD_fast,uDml_diag,vDml_diag) & -!$OMP private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP line_is_empty, keep_going,res_scaling_fac, & -!$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & -!$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) -!$OMP do + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP line_is_empty, keep_going,res_scaling_fac, & + !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & + !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) + !$OMP do do j=js-1,je+1 do i=is-1,ie+1 htot_fast(i,j) = 0.0 ; Rml_av_fast(i,j) = 0.0 @@ -359,7 +351,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) @@ -435,7 +427,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) @@ -510,12 +502,13 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nz ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -555,6 +548,22 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! This needs to happen after the H update and before the next post_data. call diag_update_remap_grids(CS%diag) +contains + !> Stream function as a function of non-dimensional position within mixed-layer + real function psi(z) + real, intent(in) :: z !< Fractional mixed layer depth [nondim] + real :: psi1, bottop, xp, dd + + !psi1 = max(0., (1. - (2.*z + 1.)**2)) + psi1 = max(0., (1. - (2.*z + 1.)**2) * (1. + (5./21.)*(2.*z + 1.)**2)) + + xp = max(0., min(1., (-z - 0.5)*2. / (1. + 2.*CS%MLE_tail_dh))) + dd = (1. - 3.*(xp**2) + 2.*(xp**3))**(1. + 2.*CS%MLE_tail_dh) + bottop = 0.5*(1. - sign(1., z + 0.5)) ! =0 for z>-0.5, =1 for z<-0.5 + + psi = max(psi1, dd*bottop) ! Combines original psi1 with tail + end function psi + end subroutine mixedlayer_restrat_general @@ -590,23 +599,23 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] real :: hx2 ! layer thickness at velocity points [H ~> m or kg m-2] - real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux - ! magnitudes (uDml & vDml) to the realized flux in a - ! layer. The vertical sum of a() through the pieces of - ! the mixed layer must be 0. + real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux magnitudes (uDml & vDml) + ! to the realized flux in a layer [nondim]. The vertical sum of a() + ! through the pieces of the mixed layer must be 0. real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! in the zonal and meridional - ! directions [T ~> s], stored in 2-D + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales in the zonal and + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D ! arrays for diagnostic purposes. - real :: uDml_diag(SZIB_(G),SZJ_(G)), vDml_diag(SZI_(G),SZJB_(G)) + real :: uDml_diag(SZIB_(G),SZJ_(G)) ! A 2D copy of uDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_diag(SZI_(G),SZJB_(G)) ! A 2D copy of vDml for diagnostics [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -619,6 +628,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) if ((nkml<2) .or. (CS%ml_restrat_coef<=0.0)) return + h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 @@ -633,14 +643,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) -!$OMP parallel default(none) shared(is,ie,js,je,G,GV,US,htot,Rml_av,tv,p0,h,h_avail,EOSdom, & -!$OMP h_neglect,g_Rho0,I4dt,CS,uhml,uhtr,dt,vhml,vhtr, & -!$OMP utimescale_diag,vtimescale_diag,forces,dz_neglect, & -!$OMP uDml_diag,vDml_diag,nkml) & -!$OMP private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & -!$OMP I2htot,z_topx2,hx2,a) & -!$OMP firstprivate(uDml,vDml) -!$OMP do + !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP I2htot,z_topx2,hx2,a) & + !$OMP firstprivate(uDml,vDml) + !$OMP do do j=js-1,je+1 do i=is-1,ie+1 htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 @@ -664,7 +670,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! 2. Add exponential tail to stream-function? ! U - Component -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z @@ -711,7 +717,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) enddo ; enddo ! V- component -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z @@ -756,12 +762,13 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) vDml_diag(i,J) = vDml(i) enddo ; enddo -!$OMP do + !$OMP do do j=js,je ; do k=1,nkml ; do i=is,ie h(i,j,k) = h(i,j,k) - dt*G%IareaT(i,j) * & ((uhml(I,j,k) - uhml(I-1,j,k)) + (vhml(i,J,k) - vhml(i,J-1,k))) + if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel ! Whenever thickness changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. @@ -921,8 +928,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, ! Rescale variables from restart files if the internal dimensional scalings have changed. if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then if (query_initialized(CS%MLD_filtered, "MLD_MLE_filtered", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%MLD_filtered(i,j) = H_rescale * CS%MLD_filtered(i,j) enddo ; enddo @@ -930,8 +937,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, endif if (CS%MLE_MLD_decay_time2>0.) then if (query_initialized(CS%MLD_filtered_slow, "MLD_MLE_filtered_slow", restart_CS) .and. & - (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= GV%m_to_H)) then - H_rescale = GV%m_to_H / GV%m_to_H_restart + (GV%m_to_H_restart /= 0.0) .and. (GV%m_to_H_restart /= 1.0)) then + H_rescale = 1.0 / GV%m_to_H_restart do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%MLD_filtered_slow(i,j) = H_rescale * CS%MLD_filtered_slow(i,j) enddo ; enddo @@ -944,14 +951,15 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, end function mixedlayer_restrat_init !> Allocate and register fields in the mixed layer restratification structure for restarts -subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) +subroutine mixedlayer_restrat_register_restarts(HI, GV, param_file, CS, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + ! Local variables - type(vardesc) :: vd logical :: mixedlayer_restrat_init ! Check to see if this module will be used @@ -966,16 +974,16 @@ subroutine mixedlayer_restrat_register_restarts(HI, param_file, CS, restart_CS) if (CS%MLE_MLD_decay_time>0. .or. CS%MLE_MLD_decay_time2>0.) then ! CS%MLD_filtered is used to keep a running mean of the PBL's actively mixed MLD. allocate(CS%MLD_filtered(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered","m","Time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered", .false., restart_CS, & + longname="Time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif if (CS%MLE_MLD_decay_time2>0.) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) - vd = var_desc("MLD_MLE_filtered_slow","m","c Slower time-filtered MLD for use in MLE", & - hor_grid='h', z_grid='1') - call register_restart_field(CS%MLD_filtered_slow, vd, .false., restart_CS) + call register_restart_field(CS%MLD_filtered, "MLD_MLE_filtered_slow", .false., restart_CS, & + longname="Slower time-filtered MLD for use in MLE", & + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif end subroutine mixedlayer_restrat_register_restarts diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8303d30621..88376e83b9 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -25,7 +25,6 @@ module MOM_thickness_diffuse #include public thickness_diffuse, thickness_diffuse_init, thickness_diffuse_end -! public vert_fill_TS public thickness_diffuse_get_KH ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -36,11 +35,14 @@ module MOM_thickness_diffuse !> Control structure for thickness diffusion type, public :: thickness_diffuse_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Khth !< Background interface depth diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] - real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion + real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion [nondim] real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max + real :: Kh_eta_bg !< Background interface height diffusivity [L2 T-1 ~> m2 s-1] + real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give + !! the interface height diffusivity [L T-1 ~> m s-1] real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. real :: kappa_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. @@ -52,7 +54,7 @@ module MOM_thickness_diffuse !! Ferrari et al., 2010, streamfunction formulation [nondim]. real :: FGNV_c_min !< A minimum wave speed used in the Ferrari et al., 2010, !! streamfunction formulation [L T-1 ~> m s-1]. - real :: N2_floor !< A floor for Brunt-Vasaila frequency in the Ferrari et al., 2010, + real :: N2_floor !< A floor for squared buoyancy frequency in the Ferrari et al., 2010, !! streamfunction formulation [T-2 ~> s-2]. logical :: detangle_interfaces !< If true, add 3-d structured interface height !! diffusivities to horizontally smooth jagged layers. @@ -67,7 +69,7 @@ module MOM_thickness_diffuse logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha!< The nondimensional coefficient governing the efficiency of - !! the GEOMETRIC thickness difussion [nondim] + !! the GEOMETRIC thickness diffusion [nondim] real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness !! diffusivity [T-1 ~> s-1]. logical :: MEKE_GEOM_answers_2018 !< If true, use expressions in the MEKE_GEOMETRIC calculation @@ -80,15 +82,18 @@ module MOM_thickness_diffuse !! top-level work tendency on the top layer. real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean !! temperature gradient in the deterministic part of the Stanley parameterization. - !! Negative values disable the scheme." [nondim] + !! Negative values disable the scheme. [nondim] type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics real, allocatable :: GMwork(:,:) !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] real, allocatable :: diagSlopeY(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] - real, allocatable :: KH_u_GME(:,:,:) !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_v_GME(:,:,:) !< interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_u(:,:) !< Interface height diffusivities at u points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_v(:,:) !< Interface height diffusivities in v points [L2 T-1 ~> m2 s-1] + + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -121,45 +126,44 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion ! Local variables - real :: e(SZI_(G), SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean + real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. - real :: uhD(SZIB_(G), SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] - real :: vhD(SZI_(G), SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: uhD(SZIB_(G),SZJ_(G),SZK_(GV)) ! Diffusive u*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] + real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: & + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & KH_u, & ! interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at u points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & KH_v, & ! interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(G), SZJ_(G)) :: & + real, dimension(SZIB_(G),SZJ_(G)) :: & KH_u_CFL ! The maximum stable interface height diffusivity at u grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJB_(G)) :: & + real, dimension(SZI_(G),SZJB_(G)) :: & KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G), SZJ_(G)) :: & + real, dimension(SZI_(G),SZJ_(G)) :: & htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] - real :: Khth_Loc_u(SZIB_(G), SZJ_(G)) - real :: Khth_Loc_v(SZI_(G), SZJB_(G)) - real :: Khth_Loc(SZIB_(G), SZJB_(G)) ! locally calculated thickness diffusivity [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) + real :: Khth_Loc_v(SZI_(G),SZJB_(G)) 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, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz - real :: hu(SZI_(G), SZJ_(G)) ! u-thickness [H ~> m or kg m-2] - real :: hv(SZI_(G), SZJ_(G)) ! v-thickness [H ~> m or kg m-2] - real :: KH_u_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: KH_v_lay(SZI_(G), SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: hu(SZI_(G),SZJ_(G)) ! u-thickness [H ~> m or kg m-2] + real :: hv(SZI_(G),SZJ_(G)) ! v-thickness [H ~> m or kg m-2] + real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Thickness diffusivities [L2 T-1 ~> m2 s-1] + real :: KH_v_lay(SZI_(G),SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -192,12 +196,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP parallel do default(none) shared(is,ie,js,je,KH_u_CFL,dt,G,CS) + !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie KH_u_CFL(I,j) = (0.25*CS%max_Khth_CFL) / & (dt * (G%IdxCu(I,j)*G%IdxCu(I,j) + G%IdyCu(I,j)*G%IdyCu(I,j))) enddo ; enddo -!$OMP parallel do default(none) shared(is,ie,js,je,KH_v_CFL,dt,G,CS) + !$OMP parallel do default(shared) do j=js-1,je ; do I=is,ie KH_v_CFL(i,J) = (0.25*CS%max_Khth_CFL) / & (dt * (G%IdxCv(i,J)*G%IdxCv(i,J) + G%IdyCv(i,J)*G%IdyCv(i,J))) @@ -207,19 +211,15 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp call find_eta(h, tv, G, GV, US, e, halo_size=1) ! Set the diffusivities. -!$OMP parallel default(none) shared(is,ie,js,je,Khth_Loc_u,CS,use_VarMix,VarMix, & -!$OMP MEKE,Resoln_scaled,KH_u,G,use_QG_Leith,use_Visbeck,& -!$OMP KH_u_CFL,nz,Khth_Loc,KH_v,KH_v_CFL,int_slope_u, & -!$OMP int_slope_v,khth_use_ebt_struct, Depth_scaled, & -!$OMP Khth_loc_v) -!$OMP do + !$OMP parallel default(shared) + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = CS%Khth enddo ; enddo if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + & CS%KHTH_Slope_Cff*VarMix%L2u(I,j) * VarMix%SN_u(I,j) @@ -229,7 +229,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) + G%mask2dCu(I,j) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i+1,j)) / & @@ -243,42 +243,42 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Res_fn_u(I,j) enddo ; enddo endif if (Depth_scaled) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = Khth_loc_u(I,j) * VarMix%Depth_fn_u(I,j) enddo ; enddo endif if (CS%Khth_Max > 0) then -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, min(Khth_loc_u(I,j), CS%Khth_Max)) enddo ; enddo else -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie Khth_loc_u(I,j) = max(CS%Khth_Min, Khth_loc_u(I,j)) enddo ; enddo endif -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie KH_u(I,j,1) = min(KH_u_CFL(I,j), Khth_loc_u(I,j)) enddo ; enddo if (khth_use_ebt_struct) then -!$OMP do + !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie KH_u(I,j,K) = KH_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) enddo ; enddo ; enddo else -!$OMP do + !$OMP do do K=2,nz+1 ; do j=js,je ; do I=is-1,ie KH_u(I,j,K) = KH_u(I,j,1) enddo ; enddo ; enddo @@ -286,7 +286,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do j=js,je ; do I=is-1,ie KH_u(I,j,k) = VarMix%KH_u_QG(I,j,k) enddo ; enddo ; enddo @@ -294,20 +294,20 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do j=js,je ; do I=is-1,ie CS%KH_u_GME(I,j,k) = KH_u(I,j,k) enddo ; enddo ; enddo endif -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = CS%Khth enddo ; enddo if (use_VarMix) then if (use_Visbeck) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) + CS%KHTH_Slope_Cff*VarMix%L2v(i,J)*VarMix%SN_v(i,J) enddo ; enddo @@ -315,7 +315,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (allocated(MEKE%Kh)) then if (CS%MEKE_GEOMETRIC) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) + G%mask2dCv(i,J) * CS%MEKE_GEOMETRIC_alpha * & 0.5*(MEKE%MEKE(i,j)+MEKE%MEKE(i,j+1)) / & @@ -329,45 +329,45 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (Resoln_scaled) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Res_fn_v(i,J) enddo ; enddo endif if (Depth_scaled) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = Khth_loc_v(i,J) * VarMix%Depth_fn_v(i,J) enddo ; enddo endif if (CS%Khth_Max > 0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, min(Khth_loc_v(i,J), CS%Khth_Max)) enddo ; enddo else -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie Khth_loc_v(i,J) = max(CS%Khth_Min, Khth_loc_v(i,J)) enddo ; enddo endif if (CS%max_Khth_CFL > 0.0) then -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie KH_v(i,J,1) = min(KH_v_CFL(i,J), Khth_loc_v(i,J)) enddo ; enddo endif if (khth_use_ebt_struct) then -!$OMP do + !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie KH_v(i,J,K) = KH_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) enddo ; enddo ; enddo else -!$OMP do + !$OMP do do K=2,nz+1 ; do J=js-1,je ; do i=is,ie KH_v(i,J,K) = KH_v(i,J,1) enddo ; enddo ; enddo @@ -375,7 +375,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (use_VarMix) then if (use_QG_Leith) then -!$OMP do + !$OMP do do k=1,nz ; do J=js-1,je ; do i=is,ie KH_v(i,J,k) = VarMix%KH_v_QG(i,J,k) enddo ; enddo ; enddo @@ -383,7 +383,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif if (CS%use_GME_thickness_diffuse) then -!$OMP do + !$OMP do do k=1,nz+1 ; do J=js-1,je ; do i=is,ie CS%KH_v_GME(i,J,k) = KH_v(i,J,k) enddo ; enddo ; enddo @@ -414,17 +414,21 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif -!$OMP do + !$OMP do do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP do + !$OMP do do K=1,nz+1 ; do J=js-1,je ; do i=is,ie ; int_slope_v(i,J,K) = 0.0 ; enddo ; enddo ; enddo -!$OMP end parallel + !$OMP end parallel if (CS%detangle_interfaces) then call add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, & CS, int_slope_u, int_slope_v) endif + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + call add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, int_slope_u, int_slope_v) + endif + if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) @@ -452,7 +456,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (VarMix%use_variable_mixing) then if (allocated(MEKE%Rd_dx_h) .and. allocated(VarMix%Rd_dx_h)) then -!$OMP parallel do default(none) shared(is,ie,js,je,MEKE,VarMix) + !$OMP parallel do default(shared) do j=js,je ; do i=is,ie MEKE%Rd_dx_h(i,j) = VarMix%Rd_dx_h(i,j) enddo ; enddo @@ -469,11 +473,10 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%id_KH_u1 > 0) call post_data(CS%id_KH_u1, KH_u(:,:,1), CS%diag) if (CS%id_KH_v1 > 0) call post_data(CS%id_KH_v1, KH_v(:,:,1), CS%diag) - ! Diagnose diffusivity at T-cell point. Do simple average, rather than - ! thickness-weighted average, in order that KH_t is depth-independent - ! in the case where KH_u and KH_v are depth independent. Otherwise, - ! if use thickness weighted average, the variations of thickness with - ! depth will place a spurious depth dependence to the diagnosed KH_t. + ! Diagnose diffusivity at T-cell point. Do a simple average, rather than a + ! thickness-weighted average, so that KH_t is depth-independent when KH_u and KH_v + ! are depth independent. If a thickness-weighted average were used, the variations + ! of thickness could give a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0 .or. CS%Use_KH_in_MEKE) then do k=1,nz ! thicknesses across u and v faces, converted to 0/1 mask @@ -523,7 +526,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif - !$OMP parallel do default(none) shared(is,ie,js,je,nz,uhtr,uhD,dt,vhtr,CDp,vhD,h,G,GV) + !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=is-1,ie uhtr(I,j,k) = uhtr(I,j,k) + uhD(I,j,k) * dt @@ -576,7 +579,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] real, intent(in) :: dt !< Time increment [T ~> s] - type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from @@ -588,9 +591,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV !! density gradients [nondim]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), optional, intent(in) :: slope_x !< Isopyc. slope at u [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), optional, intent(in) :: slope_y !< Isopyc. slope at v [Z L-1 ~> nondim] + ! Local variables - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - T, & ! The temperature (or density) [degC], with the values in + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + T, & ! The temperature [degC], with the values in ! in massless layers filled vertically by diffusion. S, & ! The filled salinity [ppt], with the values in ! in massless layers filled vertically by diffusion. @@ -598,28 +602,28 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom ! interface of a layer that is within a layer [nondim]. 0 m s-2], - ! used for calculating PE release - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: & - Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below, nondim) - hN2_x_PE ! thickness in m times Brunt-Vaisala freqeuncy at u-points [L2 Z-1 T-2 ~> m s-2], - ! used for calculating PE release - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & + Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] + hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at v-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & + Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] + hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency + ! at u-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R degC-1 ~> kg m-3 degC-1] drho_dS_u, & ! The derivative of density with salinity at u points [R ppt-1 ~> kg m-3 ppt-1]. drho_dT_dT_u ! The second derivative of density with temperature at u points [R degC-2 ~> kg m-3 degC-2] - real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ignored. real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R degC-1 ~> kg m-3 degC-1] drho_dS_v, & ! The derivative of density with salinity at v points [R ppt-1 ~> kg m-3 ppt-1]. drho_dT_dT_v ! The second derivative of density with temperature at v points [R degC-2 ~> kg m-3 degC-2] - real :: uhtot(SZIB_(G), SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: vhtot(SZI_(G), SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: uhtot(SZIB_(G),SZJ_(G)) ! The vertical sum of uhD [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: vhtot(SZI_(G),SZJB_(G)) ! The vertical sum of vhD [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [degC]. S_u, & ! Salinity on the interface at the u-point [ppt]. @@ -628,8 +632,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_v, & ! Temperature on the interface at the v-point [degC]. S_v, & ! Salinity on the interface at the v-point [ppt]. pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. - real :: Work_u(SZIB_(G), SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G), SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] + real :: Work_u(SZIB_(G),SZJ_(G)) ! The work being done by the thickness + real :: Work_v(SZI_(G),SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. @@ -639,15 +643,16 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: drdi_u(SZIB_(G),SZK_(GV)) ! Copy of drdi at u-points [R ~> kg m-3]. - real :: drdj_v(SZI_(G), SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. + real :: drdj_v(SZI_(G),SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. real :: drdkDe_u(SZIB_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at u-points ! [Z R ~> kg m-2]. real :: drdkDe_v(SZI_(G),SZK_(GV)+1) ! Lateral difference of product of drdk and e at v-points ! [Z R ~> kg m-2]. real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. - real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m]. - real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m] + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. @@ -659,14 +664,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! streamfunction [Z L2 T-1 ~> m3 s-1]. real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. - real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. - real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared. + real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] + real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that ! the units are different from other Sfn vars). real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. - real :: Slope ! The slope of density surfaces, calculated in a way - ! that is always between -1 and 1, nondimensional. + real :: Slope ! The slope of density surfaces, calculated in a way that is always + ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. real :: h_neglect ! A thickness that is so small it is usually lost @@ -676,22 +681,27 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! in roundoff and can be neglected [Z ~> m]. real :: G_scale ! The gravitational acceleration times a unit conversion ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. - logical :: use_EOS ! If true, density is calculated from T & S using an - ! equation of state. + logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] - real :: Tl(5) ! copy and T in local stencil [degC] + real :: Tl(5) ! copy of T in local stencil [degC] real :: mn_T ! mean of T in local stencil [degC] - real :: mn_T2 ! mean of T**2 in local stencil [degC] + real :: mn_T2 ! mean of T**2 in local stencil [degC2] real :: hl(5) ! Copy of local stencil of H [H ~> m] real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tsgs2 ! Sub-grid temperature variance [degC2] - - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: diag_sfn_x, diag_sfn_unlim_x ! Diagnostics - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: diag_sfn_y, diag_sfn_unlim_y ! Diagnostics + real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [degC2] + + real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction + ! [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before + ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of ! state calculations at u-points. @@ -735,12 +745,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") -!$OMP parallel default(none) shared(is,ie,js,je,h_avail_rsum,pres,h_avail,I4dt, use_Stanley, & -!$OMP CS,G,GV,tv,h,h_frac,nz,uhtot,Work_u,vhtot,Work_v,Tsgs2,T, & -!$OMP diag_sfn_x, diag_sfn_y, diag_sfn_unlim_x, diag_sfn_unlim_y ) & -!$OMP private(hl,r_sm_H,Tl,mn_T,mn_T2) + !$OMP parallel default(shared) private(hl,r_sm_H,Tl,mn_T,mn_T2) ! Find the maximum and minimum permitted streamfunction. -!$OMP do + !$OMP do do j=js-1,je+1 ; do i=is-1,ie+1 h_avail_rsum(i,j,1) = 0.0 pres(i,j,1) = 0.0 @@ -752,7 +759,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV pres(i,j,2) = pres(i,j,1) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,1) enddo ; enddo if (use_Stanley) then -!$OMP do + !$OMP do do k=1, nz ; do j=js-1,je+1 ; do i=is-1,ie+1 !! SGS variance in i-direction [degC2] !dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & @@ -786,7 +793,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV Tsgs2(i,j,k) = CS%Stanley_det_coeff * max(0., mn_T2) enddo ; enddo ; enddo endif -!$OMP do + !$OMP do do j=js-1,je+1 do k=2,nz ; do i=is-1,ie+1 h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) @@ -796,34 +803,36 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV pres(i,j,K+1) = pres(i,j,K) + (GV%g_Earth*GV%H_to_RZ) * h(i,j,k) enddo ; enddo enddo -!$OMP do + !$OMP do do j=js,je ; do I=is-1,ie uhtot(I,j) = 0.0 ; Work_u(I,j) = 0.0 - diag_sfn_x(I,j,1) = 0.0 ; diag_sfn_unlim_x(I,j,1) = 0.0 - diag_sfn_x(I,j,nz+1) = 0.0 ; diag_sfn_unlim_x(I,j,nz+1) = 0.0 enddo ; enddo -!$OMP do + !$OMP do do J=js-1,je ; do i=is,ie vhtot(i,J) = 0.0 ; Work_v(i,J) = 0.0 - diag_sfn_y(i,J,1) = 0.0 ; diag_sfn_unlim_y(i,J,1) = 0.0 - diag_sfn_y(i,J,nz+1) = 0.0 ; diag_sfn_unlim_y(i,J,nz+1) = 0.0 enddo ; enddo -!$OMP end parallel - - EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & -!$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & -!$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & -!$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & -!$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & -!$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_u,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & -!$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + !$OMP end parallel + + if (CS%id_sfn_x > 0) then ; diag_sfn_x(:,:,1) = 0.0 ; diag_sfn_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_y > 0) then ; diag_sfn_y(:,:,1) = 0.0 ; diag_sfn_y(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_x > 0) then ; diag_sfn_unlim_x(:,:,1) = 0.0 ; diag_sfn_unlim_x(:,:,nz+1) = 0.0 ; endif + if (CS%id_sfn_unlim_y > 0) then ; diag_sfn_unlim_y(:,:,1) = 0.0 ; diag_sfn_unlim_y(:,:,nz+1) = 0.0 ; endif + + EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & + !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & + !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & + !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & + !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_u,scrap, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & + !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do j=js,je do I=is-1,ie ; hN2_u(I,1) = 0. ; hN2_u(I,nz+1) = 0. ; enddo do K=nz,2,-1 @@ -1064,7 +1073,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. Work_u(I,j) = Work_u(I,j) + G_scale * & @@ -1077,21 +1086,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of k-loop enddo ! end of j-loop - ! Calculate the meridional fluxes and gradients. - EOSdom_v(:) = EOS_domain(G%HI) -!$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & -!$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & -!$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & -!$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & -!$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & -!$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & -!$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & -!$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & -!$OMP drho_dT_dT_v,scrap, & -!$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & -!$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & -!$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & -!$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) + ! Calculate the meridional fluxes and gradients. + EOSdom_v(:) = EOS_domain(G%HI) + + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & + !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & + !$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & + !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & + !$OMP drho_dT_dT_v,scrap, & + !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & + !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & + !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do J=js-1,je do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then @@ -1329,7 +1339,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! This is the energy tendency based on the original profiles, and does ! not include any nonlinear terms due to a finite time step (which would ! involve interactions between the fluxes through the different faces. - ! A second order centered estimate is used for the density transfered + ! A second order centered estimate is used for the density transferred ! between water columns. Work_v(i,J) = Work_v(i,J) + G_scale * & @@ -1442,10 +1452,12 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables + real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] + real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] + real :: b_denom ! A term in the denominator of beta [L2 Z-1 T-2 ~> m s-2] + real :: beta ! The normalization for the pivot [Z T2 L-2 ~> s2 m-1] integer :: k - real :: b_denom, beta, d1, c1(nk) - sfn(1) = 0. b_denom = hN2(2) + c2_h(1) beta = 1.0 / ( b_denom + c2_h(2) ) @@ -1466,6 +1478,48 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver +!> Add a diffusivity that acts on the interface heights, regardless of the densities +subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_slope_u, int_slope_v) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness diffusion + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces + !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity + !! at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of + !! the isopycnal slopes are taken directly from + !! the interface slopes without consideration + !! of density gradients. + + ! Local variables + integer :: i, j, k, is, ie, js, je, nz + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + do k=1,nz+1 ; do j=js,je ; do I=is-1,ie ; if (CS%Kh_eta_u(I,j) > 0.0) then + int_slope_u(I,j,K) = (int_slope_u(I,j,K)*Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) / & + (Kh_u(I,j,K) + CS%Kh_eta_u(I,j)) + Kh_u(I,j,K) = min(Kh_u(I,j,K) + CS%Kh_eta_u(I,j), Kh_u_CFL(I,j)) + endif ; enddo ; enddo ; enddo + + do k=1,nz+1 ; do J=js-1,je ; do i=is,ie ; if (CS%Kh_eta_v(i,J) > 0.0) then + int_slope_v(i,J,K) = (int_slope_v(i,J,K)*Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) / & + (Kh_v(i,J,K) + CS%Kh_eta_v(i,J)) + Kh_v(i,J,K) = min(Kh_v(i,J,K) + CS%Kh_eta_v(i,J), Kh_v_CFL(i,J)) + endif ; enddo ; enddo ; enddo + +end subroutine add_interface_Kh + !> Modifies thickness diffusivities to untangle layer structures subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) @@ -1510,7 +1564,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! with the thinner modified near the boundaries to mask out ! thickness variations due to topography, etc. real :: jag_Rat ! The nondimensional jaggedness ratio for a layer, going - ! from 0 (smooth) to 1 (jagged). This is the difference + ! from 0 (smooth) to 1 (jagged) [nondim]. This is the difference ! between the arithmetic and harmonic mean thicknesses ! normalized by the arithmetic mean thickness. real :: Kh_scale ! A ratio by which Kh_u_CFL is scaled for maximally jagged @@ -1527,20 +1581,22 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! and the ratio of the face length to the adjacent cell ! areas for comparability with the diffusivities [L Z T-1 ~> m2 s-1]. real :: adH ! The absolute value of dH [L Z T-1 ~> m2 s-1]. - real :: sign ! 1 or -1, with the same sign as the layer thickness gradient. + real :: sign ! 1 or -1, with the same sign as the layer thickness gradient [nondim]. real :: sl_K ! The sign-corrected slope of the interface above [Z L-1 ~> nondim]. real :: sl_Kp1 ! The sign-corrected slope of the interface below [Z L-1 ~> nondim]. real :: I_sl_K ! The (limited) inverse of sl_K [L Z-1 ~> nondim]. real :: I_sl_Kp1 ! The (limited) inverse of sl_Kp1 [L Z-1 ~> nondim]. real :: I_4t ! A quarter of a flux scaling factor divided by ! the damping timescale [T-1 ~> s-1]. - real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1. - real :: denom, I_denom ! A denominator and its inverse, various units. + real :: Fn_R ! A function of Rsl, such that Rsl < Fn_R < 1 [nondim] + real :: Idx_eff ! The effective inverse x-grid spacing at a u-point [L-1 ~> m-1] + real :: Idy_eff ! The effective inverse y-grid spacing at a v-point [L-1 ~> m-1] + real :: slope_sq ! The sum of the squared slopes above and below a layer [Z2 L-2 ~> nondim] real :: Kh_max ! A local ceiling on the diffusivity [L2 T-1 ~> m2 s-1]. - real :: wt1, wt2 ! Nondimensional weights. + real :: wt1, wt2 ! Nondimensional weights [nondim]. ! Variables used only in testing code. - ! real, dimension(SZK_(GV)) :: uh_here - ! real, dimension(SZK_(GV)+1) :: Sfn + ! real, dimension(SZK_(GV)) :: uh_here ! The transport in a layer [Z L2 T-1 ~> m3 s-1] + ! real, dimension(SZK_(GV)+1) :: Sfn ! The streamfunction at an interface [Z L T-1 ~> m2 s-1] real :: dKh ! An increment in the diffusivity [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & @@ -1567,7 +1623,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV Kh_max_p , & ! See above [nondim]. Kh0_max_p ! See above [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G)) :: & - Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1].. + Kh_max_max ! The maximum diffusivity permitted in a column [L2 T-1 ~> m2 s-1] logical, dimension(SZIB_(G)) :: & do_i ! If true, work on a column. integer :: i, j, k, n, ish, jsh, is, ie, js, je, nz, k_top @@ -1662,49 +1718,49 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV do k=k_top,nz ; do i=ish,ie ; if (do_i(i)) then if (n==1) then ! This is a u-column. dH = 0.0 - denom = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) + Idx_eff = ((G%IareaT(i+1,j) + G%IareaT(i,j)) * G%dy_Cu(I,j)) ! This expression uses differences in e in place of h for better ! consistency with the slopes. - if (denom > 0.0) & + if (Idx_eff > 0.0) & dH = I_4t * ((e(i+1,j,K) - e(i+1,j,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idx_eff + ! dH = I_4t * (h(i+1,j,k) - h(i,j,k)) / Idx_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j) sl_Kp1 = sign * (e(i+1,j,K+1)-e(i,j,K+1)) * G%IdxCu(I,j) - ! Add the incremental diffusivites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_u(I,j,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_u(I,j,k) else ! This is a v-column. dH = 0.0 - denom = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) - if (denom > 0.0) & + Idy_eff = ((G%IareaT(i,j+1) + G%IareaT(i,j)) * G%dx_Cv(I,j)) + if (Idy_eff > 0.0) & dH = I_4t * ((e(i,j+1,K) - e(i,j+1,K+1)) - & - (e(i,j,K) - e(i,j,K+1))) / denom - ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / denom + (e(i,j,K) - e(i,j,K+1))) / Idy_eff + ! dH = I_4t * (h(i,j+1,k) - h(i,j,k)) / Idy_eff adH = abs(dH) sign = 1.0 ; if (dH < 0) sign = -1.0 sl_K = sign * (e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J) sl_Kp1 = sign * (e(i,j+1,K+1)-e(i,j,K+1)) * G%IdyCv(i,J) - ! Add the incremental diffusviites to the surrounding interfaces. + ! Add the incremental diffusivities to the surrounding interfaces. ! Adding more to the more steeply sloping layers (as below) makes ! the diffusivities more than twice as effective. - denom = (sl_K**2 + sl_Kp1**2) + slope_sq = (sl_K**2 + sl_Kp1**2) wt1 = 0.5 ; wt2 = 0.5 - if (denom > 0.0) then - wt1 = sl_K**2 / denom ; wt2 = sl_Kp1**2 / denom + if (slope_sq > 0.0) then + wt1 = sl_K**2 / slope_sq ; wt2 = sl_Kp1**2 / slope_sq endif Kh_detangle(I,K) = Kh_detangle(I,K) + wt1*KH_lay_v(i,J,k) Kh_detangle(I,K+1) = Kh_detangle(I,K+1) + wt2*KH_lay_v(i,J,k) @@ -1784,7 +1840,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV ! Kh(I,K) <= Kh_max_m(I,K)*Kh(I,K-1) + Kh0_max_m(I,K) ! Kh(I,K) <= Kh_max_p(I,K)*Kh(I,K+1) + Kh0_max_p(I,K) - ! Increase the diffusivies to satisfy the min constraints. + ! Increase the diffusivities to satisfy the min constraints. ! All non-zero min constraints on one diffusivity are max constraints on another. do K=k_top+1,nz ; do i=ish,ie ; if (do_i(i)) then Kh(I,K) = max(Kh_bg(I,K), Kh_detangle(I,K), & @@ -1892,14 +1948,17 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + real :: grid_sp ! The local grid spacing [L ~> m] real :: omega ! The Earth's rotation rate [T-1 ~> s-1] - real :: strat_floor ! A floor for Brunt-Vasaila frequency in the Ferrari et al. 2010, + real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, ! streamfunction formulation, expressed as a fraction of planetary ! rotation [nondim]. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. + integer :: i, j CS%initialized = .true. CS%diag => diag @@ -1929,9 +1988,30 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "much smaller numbers (e.g. 0.1) seem to work better for "//& "ALE-based models.", units = "nondimensional", default=0.8) -! call get_param(param_file, mdl, "USE_QG_LEITH_GM", CS%QG_Leith_GM, & -! "If true, use the QG Leith viscosity as the GM coefficient.", & -! default=.false.) + call get_param(param_file, mdl, "KH_ETA_CONST", CS%Kh_eta_bg, & + "The background horizontal diffusivity of the interface heights (without "//& + "considering the layer density structure). If diffusive CFL limits are "//& + "encountered, the diffusivities of the isopycnals and the interfaces heights "//& + "are scaled back proportionately.", & + default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KH_ETA_VEL_SCALE", CS%Kh_eta_vel, & + "A velocity scale that is multiplied by the grid spacing to give a contribution "//& + "to the horizontal diffusivity of the interface heights (without considering "//& + "the layer density structure).", & + default=0.0, units="m s-1", scale=US%m_to_L*US%T_to_s) + + if ((CS%Kh_eta_bg > 0.0) .or. (CS%Kh_eta_vel > 0.0)) then + allocate(CS%Kh_eta_u(G%IsdB:G%IedB, G%jsd:G%jed), source=0.) + allocate(CS%Kh_eta_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.) + do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + grid_sp = sqrt((2.0*G%dxCu(I,j)**2 * G%dyCu(I,j)**2) / (G%dxCu(I,j)**2 + G%dyCu(I,j)**2)) + CS%Kh_eta_u(I,j) = G%mask2dCu(I,j) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + grid_sp = sqrt((2.0*G%dxCv(i,J)**2 * G%dyCv(i,J)**2) / (G%dxCv(i,J)**2 + G%dyCv(i,J)**2)) + CS%Kh_eta_v(i,J) = G%mask2dCv(i,J) * MAX(0.0, CS%Kh_eta_bg + CS%Kh_eta_vel * grid_sp) + enddo ; enddo + endif if (CS%max_Khth_CFL < 0.0) CS%max_Khth_CFL = 0.0 call get_param(param_file, mdl, "DETANGLE_INTERFACES", CS%detangle_interfaces, & @@ -2171,12 +2251,12 @@ end subroutine thickness_diffuse_end !! \f[ !! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) !! \f] -!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the square root of Brunt-Vaisala frequency, +!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the Brunt-Vaisala frequency, !! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and !! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, !! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module !! (enabled with USE_VARIABLE_MIXING=True and the term \f$\f$ is the vertical average slope -!! times the Brunt-Vaisala frequency prescribed by Visbeck et al., 1996. +!! times the buoyancy frequency prescribed by Visbeck et al., 1996. !! !! The result of the above expression is subsequently bounded by minimum and maximum values, including an upper !! diffusivity consistent with numerical stability (\f$ \kappa_{cfl} \f$ is calculated internally). @@ -2220,7 +2300,7 @@ end subroutine thickness_diffuse_end !! A boundary-value problem for the parameterized mesoscale eddy transport. !! Ocean Modelling, 32, 143-156. http://doi.org/10.1016/j.ocemod.2010.01.004 !! -!! Viscbeck, M., J.C. Marshall, H. Jones, 1996: +!! Visbeck, M., J.C. Marshall, H. Jones, 1996: !! Dynamics of isolated convective regions in the ocean. J. Phys. Oceangr., 26, 1721-1734. !! http://dx.doi.org/10.1175/1520-0485(1996)026%3C1721:DOICRI%3E2.0.CO;2 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index f1d6e6bb57..b8a9b3134c 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -246,11 +246,9 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) real, dimension(MAX_CONSTITUENTS) :: amp_def ! Default amplitude for each tidal constituent [m] real, dimension(MAX_CONSTITUENTS) :: love_def ! Default love number for each constituent [nondim] integer, dimension(3) :: tide_ref_date !< Reference date (t = 0) for tidal forcing. - logical :: use_const ! True if a constituent is being used. logical :: use_M2, use_S2, use_N2, use_K2, use_K1, use_O1, use_P1, use_Q1 logical :: use_MF, use_MM logical :: tides ! True if a tidal forcing is to be used. - logical :: FAIL_IF_MISSING = .true. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 21a22a222e..737ed8286e 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -58,7 +58,6 @@ subroutine stochastics_init(dt, grid, GV, CS, param_file, diag, Time) integer :: mom_comm ! list of pes for this instance of the ocean integer :: num_procs ! number of processors to pass to stochastic physics integer :: iret ! return code from stochastic physics - integer :: me ! my pe integer :: pe_zero ! root pe integer :: nx ! number of x-points including halo integer :: ny ! number of x-points including halo diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 472ee21e36..7be84d2522 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -143,7 +143,7 @@ module MOM_ALE_sponge !> This subroutine determines the number of points which are within sponges in this computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean -!! points are included in the sponges. It also stores the target interface heights. This +!! points are included in the sponges. It also stores the target interface heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & Iresttime_u_in, Iresttime_v_in) @@ -163,16 +163,18 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! time at v-points [T-1 ~> s-1]. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_sponge" ! This module's name. - logical :: use_sponge real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme + if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_fixed called with an associated "// & "control structure.") @@ -228,7 +230,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -239,7 +241,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 @@ -273,15 +275,15 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! u points CS%num_col_u = 0 ; if (present(Iresttime_u_in)) then - Iresttime_u(:,:) = Iresttime_u_in(:,:) + Iresttime_u(:,:) = Iresttime_u_in(:,:) else do j=G%jsc,G%jec ; do I=G%iscB,G%iecB Iresttime_u(I,j) = 0.5 * (Iresttime(i,j) + Iresttime(i+1,j)) enddo ; enddo endif do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & - CS%num_col_u = CS%num_col_u + 1 + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & + CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -293,7 +295,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! Store the column indices and restoring rates in the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = I ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(I,j) col = col + 1 @@ -324,7 +326,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo endif do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo @@ -337,7 +339,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -422,17 +424,17 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring time !! for v [T-1 ~> s-1]. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "MOM_sponge" ! This module's name. - logical :: use_sponge real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=64) :: remapScheme + logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries logical :: default_2018_answers - logical :: spongeDataOngrid = .false. - integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v - character(len=10) :: remapScheme + integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then call MOM_error(WARNING, "initialize_ALE_sponge_varying called with an associated "// & @@ -489,7 +491,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo if (CS%num_col > 0) then @@ -499,7 +501,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col + 1 @@ -529,7 +531,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_u = 0 ; do j=G%jsc,G%jec; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) & + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) & CS%num_col_u = CS%num_col_u + 1 enddo ; enddo if (CS%num_col_u > 0) then @@ -539,7 +541,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do j=G%jsc,G%jec ; do I=G%iscB,G%iecB - if ((Iresttime_u(I,j)>0.0) .and. (G%mask2dCu(I,j)>0)) then + if ((Iresttime_u(I,j) > 0.0) .and. (G%mask2dCu(I,j) > 0.0)) then CS%col_i_u(col) = i ; CS%col_j_u(col) = j CS%Iresttime_col_u(col) = Iresttime_u(i,j) col = col + 1 @@ -561,7 +563,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest endif CS%num_col_v = 0 ; do J=G%jscB,G%jecB; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) & + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) & CS%num_col_v = CS%num_col_v + 1 enddo ; enddo if (CS%num_col_v > 0) then @@ -571,7 +573,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest ! pass indices, restoring time to the CS structure col = 1 do J=G%jscB,G%jecB ; do i=G%isc,G%iec - if ((Iresttime_v(i,J)>0.0) .and. (G%mask2dCv(i,J)>0)) then + if ((Iresttime_v(i,J) > 0.0) .and. (G%mask2dCv(i,J) > 0.0)) then CS%col_i_v(col) = i ; CS%col_j_v(col) = j CS%Iresttime_col_v(col) = Iresttime_v(i,j) col = col + 1 @@ -625,7 +627,7 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & target, intent(in) :: f_ptr !< Pointer to the field to be damped - integer :: j, k, col + integer :: k, col character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return @@ -667,19 +669,11 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). ! Local variables - real, allocatable, dimension(:,:,:) :: sp_val !< Field to be used in the sponge - real, allocatable, dimension(:,:,:) :: mask_z !< Field mask for the sponge data - real, allocatable, dimension(:), target :: z_in, z_edges_in ! Heights [Z ~> m]. - real :: missing_value - integer :: j, k, col - integer :: isd,ied,jsd,jed - integer :: nPoints + integer :: isd, ied, jsd, jed integer, dimension(4) :: fld_sz integer :: nz_data !< the number of vertical levels in this input field character(len=256) :: mesg ! String for error messages ! Local variables for ALE remapping - real :: zTopOfCell, zBottomOfCell ! Heights [Z ~> m]. - type(remapping_CS) :: remapCS ! Remapping parameters and work arrays if (.not.associated(CS)) return ! initialize time interpolator module @@ -688,7 +682,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, CS%fldno = CS%fldno + 1 if (CS%fldno > MAX_FIELDS_) then write(mesg, '("Increase MAX_FIELDS_ to at least ",I3," in MOM_memory.h or decrease "//& - "the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno + &"the number of fields to be damped in the call to initialize_ALE_sponge." )') CS%fldno call MOM_error(FATAL,"set_up_ALE_sponge_field: "//mesg) endif ! get a unique time interp id for this field. If sponge data is on-grid, then setup @@ -728,8 +722,7 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] - integer :: j, k, col, fld_sz(4) - character(len=256) :: mesg ! String for error messages + integer :: k, col if (.not.associated(CS)) return @@ -768,19 +761,10 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] ! Local variables - real, allocatable, dimension(:,:,:) :: u_val !< U field to be used in the sponge [L T-1 ~> m s-1]. - real, allocatable, dimension(:,:,:) :: v_val !< V field to be used in the sponge [L T-1 ~> m s-1]. - - real, allocatable, dimension(:), target :: z_in, z_edges_in - real :: missing_value logical :: override - - integer :: j, k, col integer :: isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB integer, dimension(4) :: fld_sz - character(len=256) :: mesg ! String for error messages - integer :: tmp if (.not.associated(CS)) return override =.true. @@ -835,7 +819,6 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. - real :: m_to_Z ! A unit conversion factor from m to Z. real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid real, dimension(SZK_(GV)) :: h_col ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] @@ -849,8 +832,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. ! Local variables for ALE remapping real, dimension(:), allocatable :: tmpT1d - integer :: c, m, nkmb, i, j, k, is, ie, js, je, nz, nz_data - integer :: col, total_sponge_cols + integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the ! edges in the input file [Z ~> m] @@ -962,7 +944,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) then nz_data = CS%Ref_val_u%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, 1.0, G, sp_val, mask_z, z_in, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, Time, US%m_s_to_L_T, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) @@ -1011,7 +993,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) deallocate(sp_val, mask_u, mask_z, hsrc) nz_data = CS%Ref_val_v%nz_data ! Interpolate from the external horizontal grid and in time - call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, 1.0, G, sp_val, mask_z, z_in, & + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, Time, US%m_s_to_L_T, G, sp_val, mask_z, z_in, & z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& answers_2018=CS%hor_regrid_answers_2018) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d12d850a73..30818a6f1f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -77,8 +77,8 @@ module MOM_CVMix_KPP real :: cs2 !< Parameter for multiplying by non-local term ! This is active for NLT_SHAPE_CUBIC_LMD only logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. - character(len=10) :: interpType !< Type of interpolation to compute bulk Richardson number - character(len=10) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth + character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number + character(len=32) :: interpType2 !< Type of interpolation to compute diff and visc at OBL_depth logical :: computeEkman !< If True, compute Ekman depth limit for OBLdepth logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity @@ -199,7 +199,6 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) character(len=20) :: string !< local temporary string character(len=20) :: langmuir_mixing_opt = 'NONE' !< langmuir mixing opt to be passed to CVMix, e.g., LWF16 character(len=20) :: langmuir_entrainment_opt = 'NONE' !< langmuir entrainment opt to be passed to CVMix, e.g., LWF16 - character(len=20) :: wave_method logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) !! False => compute G'(1) as in LMD94 @@ -947,7 +946,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: surfFricVel, surfBuoyFlux, Coriolis real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] - real :: rho1, rhoK, Uk, Vk, sigma, sigmaRatio + real :: Uk, Vk real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. @@ -966,11 +965,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear real, dimension(GV%ke) :: U_H, V_H real :: MLD_GUESS, LA - real :: surfHuS, surfHvS, surfUs, surfVs, wavedir, currentdir - real :: VarUp, VarDn, M, VarLo, VarAvg - real :: H10pct, H20pct,CMNFACT, USx20pct, USy20pct, enhvt2 - integer :: B - real :: WST + real :: surfHuS, surfHvS, surfUs, surfVs if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") @@ -995,7 +990,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, enhvt2, wst, & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, u, v, lamult) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 7371ba7009..58d6e3417a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -293,7 +293,7 @@ end subroutine calculate_CVMix_conv logical function CVMix_conv_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_conv_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index f1ac4c926a..b77387f521 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -174,7 +174,6 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - integer :: kOBL !< level of OBL extent real :: dh, hcorr integer :: i, k @@ -274,7 +273,7 @@ end subroutine compute_ddiff_coeffs logical function CVMix_ddiff_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMIX_DDIFF", CVMix_ddiff_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_ddiff_is_used diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index eed99ceb3f..db98e063d8 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -326,9 +326,9 @@ logical function CVMix_shear_is_used(param_file) ! Local variables logical :: LMD94, PP81 call get_param(param_file, mdl, "USE_LMD94", LMD94, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) call get_param(param_file, mdl, "Use_PP81", PP81, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index c3ee727573..fb218a7d67 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -523,7 +523,7 @@ end subroutine calculate_bkgnd_mixing logical function CVMix_bkgnd_is_used(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters call get_param(param_file, mdl, "USE_CVMix_BACKGROUND", CVMix_bkgnd_is_used, & - default=.false., do_not_log = .true.) + default=.false., do_not_log=.true.) end function CVMix_bkgnd_is_used diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 11df20f5ea..73fc288731 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -321,7 +321,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, nz, nkmb, n + integer :: i, j, k, is, ie, js, je, nz, nkmb integer :: nsw ! The number of bands of penetrating shortwave radiation. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -783,8 +783,6 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! Local variables real, dimension(SZI_(G)) :: & - htot, & ! The total depth of the layers being considered for - ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. Rcv_tot, & ! The integrated coordinate value potential density of the @@ -1001,7 +999,6 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! shortwave radiation, integrated over a layer ! [H R ~> kg m-2 or kg2 m-5]. real :: Idt ! 1.0/dt [T-1 ~> s-1] - real :: netHeatOut ! accumulated heat content of mass leaving ocean integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & C2, & ! Temporary variable R H-1 ~> kg m-4 or m-1]. @@ -2297,7 +2294,6 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. real :: h2_to_k1_lim, T_new, S_new, T_max, T_min, S_max, S_min - character(len=200) :: mesg integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 13d25f06f5..405251eaee 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -527,7 +527,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) do j=js,je do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_w(i) = G%areaCu(I-1,j) * Idenom a_e(i) = G%areaCu(I,j) * Idenom @@ -536,7 +536,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) endif sum_area = G%areaCv(i,J-1) + G%areaCv(i,J) - if (sum_area>0.0) then + if (sum_area > 0.0) then Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_s(i) = G%areaCv(i,J-1) * Idenom a_n(i) = G%areaCv(i,J) * Idenom @@ -607,7 +607,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow real, dimension(SZI_(G),SZJ_(G)) :: chl_2d !< Vertically uniform chlorophyll-A concentractions [mg m-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: chl_3d !< The chlorophyll-A concentractions of each layer [mg m-3] character(len=128) :: mesg - integer :: i, j, k, is, ie, js, je + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec if (.not.associated(optics)) return @@ -618,7 +618,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow ! same value is assumed for all layers. call time_interp_external(CS%sbc_chl, CS%Time, chl_2d) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_2d(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -650,7 +650,7 @@ end subroutine set_pen_shortwave !> Diagnose a mixed layer depth (MLD) determined by a given density difference with the surface. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, diagPtr, & id_N2subML, id_MLDsq, dz_subML) type(ocean_grid_type), intent(in) :: G !< Grid type @@ -768,7 +768,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! endif call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) - do i=is,ie ; if ((G%mask2dT(i,j)>0.5) .and. N2_region_set(i)) then + do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) endif ; enddo endif @@ -781,7 +781,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, end subroutine diagnoseMLDbyDensityDifference !> Diagnose a mixed layer depth (MLD) determined by the depth a given energy value would mix. -!> This routine is appropriate in MOM_diabatic_driver due to its position within the time stepping. +!> This routine is appropriate in MOM_diabatic_aux due to its position within the time stepping. subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! Author: Brandon Reichl ! Date: October 2, 2020 @@ -820,7 +820,6 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real, dimension(SZK_(GV)) :: Z_L, Z_U, dZ, Rho_c, pRef_MLD real, dimension(3) :: PE_threshold - real :: ig, E_g real :: PE_Threshold_fraction, PE, PE_Mixed, PE_Mixed_TST real :: RhoDZ_ML, H_ML, RhoDZ_ML_TST, H_ML_TST real :: Rho_ML @@ -1078,7 +1077,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t logical :: calculate_energetics logical :: calculate_buoyancy integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, is, ie, js, je, k, nz, n, nb + integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1227,7 +1226,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t else netMassIn(i) = netMassInOut(i) - netMassOut(i) endif - if (G%mask2dT(i,j)>0.0) then + if (G%mask2dT(i,j) > 0.0) then fluxes%netMassOut(i,j) = netMassOut(i) fluxes%netMassIn(i,j) = netMassIn(i) else @@ -1377,7 +1376,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t write(0,*) 'applyBoundaryFluxesInOut(): netT,netS,netH=',netHeat(i),netSalt(i),netMassInOut(i) write(0,*) 'applyBoundaryFluxesInOut(): dT,dS,dH=',dTemp,dSalt,dThickness write(0,*) 'applyBoundaryFluxesInOut(): h(n),h(n+1),k=',hOld,h2d(i,k),k - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Complete mass loss in column!") endif @@ -1392,7 +1391,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t write(0,*) 'applyBoundaryFluxesInOut(): netHeat,netSalt,netMassIn,netMassOut=',& netHeat(i),netSalt(i),netMassIn(i),netMassOut(i) - call MOM_error(FATAL, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass loss over land?") endif @@ -1526,13 +1525,13 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & G%geoLatT( iGround(i), jGround(i)), hGrounding(i)*GV%H_to_m - call MOM_error(WARNING, "MOM_diabatic_driver.F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Mass created. x,y,dh= "//trim(mesg), all_print=.true.) enddo if (numberOfGroundings - maxGroundings > 0) then write(mesg, '(i4)') numberOfGroundings - maxGroundings - call MOM_error(WARNING, "MOM_diabatic_driver:F90, applyBoundaryFluxesInOut(): "//& + call MOM_error(WARNING, "MOM_diabatic_aux:F90, applyBoundaryFluxesInOut(): "//& trim(mesg) // " groundings remaining") endif endif @@ -1558,14 +1557,13 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori ! This "include" declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. - character(len=48) :: thickness_units character(len=200) :: inputdir ! The directory where NetCDF input files character(len=240) :: chl_filename ! A file from which chl_a concentrations are to be read. character(len=128) :: chl_file ! Data containing chl_a concentrations. Used ! when var_pen_sw is defined and reading from file. character(len=32) :: chl_varname ! Name of chl_a variable in chl_file. logical :: use_temperature ! True if thermodynamics are enabled. - integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz, nbands + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7b180f1d65..1a5471c79d 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -81,7 +81,6 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init -! public legacy_diabatic ! 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 @@ -185,7 +184,7 @@ module MOM_diabatic_driver integer :: id_MLD_003 = -1, id_MLD_0125 = -1, id_MLD_user = -1, id_mlotstsq = -1 integer :: id_MLD_EN1 = -1, id_MLD_EN2 = -1, id_MLD_EN3 = -1, id_subMLN2 = -1 - ! These are handles to diatgnostics that are only available in non-ALE layered mode. + ! These are handles to diagnostics that are only available in non-ALE layered mode. integer :: id_wd = -1 integer :: id_dudt_dia = -1, id_dvdt_dia = -1 integer :: id_hf_dudt_dia_2d = -1, id_hf_dvdt_dia_2d = -1 @@ -303,27 +302,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & integer :: i, j, k, m, is, ie, js, je, nz logical :: showCallTree ! If true, show the call tree - real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics - real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics - real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics - real :: t_tend,s_tend,h_tend ! holder for tendencey needed for SPPT - real :: t_pert,s_pert,h_pert ! holder for perturbations needed for SPPT - - if (G%ke == 1) return - - ! save copy of the date for SPPT if active - if (stoch_CS%do_sppt) then - allocate(h_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(t_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - allocate(s_in(G%isd:G%ied, G%jsd:G%jed,G%ke)) - h_in(:,:,:)=h(:,:,:) - t_in(:,:,:)=tv%T(:,:,:) - s_in(:,:,:)=tv%S(:,:,:) - - if (stoch_CS%id_sppt_wts > 0) then - call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) - endif - endif + real, allocatable, dimension(:,:,:) :: h_in ! thickness before thermodynamics [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: t_in ! temperature before thermodynamics [degC] + real, allocatable, dimension(:,:,:) :: s_in ! salinity before thermodynamics [ppt] if (GV%ke == 1) return @@ -342,7 +323,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & showCallTree = callTree_showQuery() - ! Offer diagnostics of various state varables at the start of diabatic + ! Offer diagnostics of various state variables at the start of diabatic ! these are mostly for debugging purposes. if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) @@ -354,6 +335,13 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call post_data(CS%id_e_predia, eta, CS%diag) endif + ! Save a copy of the initial state if stochastic perturbations are active. + if (stoch_CS%do_sppt) then + allocate(h_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; h_in(:,:,:) = h(:,:,:) + allocate(t_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; t_in(:,:,:) = tv%T(:,:,:) + allocate(s_in(G%isd:G%ied, G%jsd:G%jed, GV%ke)) ; s_in(:,:,:) = tv%S(:,:,:) + endif + if (CS%debug) then call MOM_state_chksum("Start of diabatic ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("Start of diabatic", fluxes, G, US, haloshift=0) @@ -456,6 +444,16 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! endif for frazil + if (stoch_CS%do_sppt) then + ! perturb diabatic tendencies. + ! These stochastic perturbations do not conserve heat, salt or mass. + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = max(h_in(i,j,k) + (h(i,j,k)-h_in(i,j,k)) * stoch_CS%sppt_wts(i,j), GV%Angstrom_H) + tv%T(i,j,k) = t_in(i,j,k) + (tv%T(i,j,k)-t_in(i,j,k)) * stoch_CS%sppt_wts(i,j) + tv%S(i,j,k) = max(s_in(i,j,k) + (tv%S(i,j,k)-s_in(i,j,k)) * stoch_CS%sppt_wts(i,j), 0.0) + enddo ; enddo ; enddo + deallocate(h_in, t_in, s_in) + endif ! Diagnose mixed layer depths. call enable_averages(dt, Time_end, CS%diag) @@ -477,38 +475,14 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (CS%id_cg1 > 0) call post_data(CS%id_cg1, cn_IGW(:,:,1),CS%diag) do m=1,CS%nMode ; if (CS%id_cn(m) > 0) call post_data(CS%id_cn(m), cn_IGW(:,:,m), CS%diag) ; enddo endif + + if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & + call post_data(stoch_CS%id_sppt_wts, stoch_CS%sppt_wts, CS%diag) + call disable_averaging(CS%diag) if (CS%debugConservation) call MOM_state_stats('leaving diabatic', u, v, h, tv%T, tv%S, G, GV, US) - if (stoch_CS%do_sppt) then - ! perturb diabatic tendecies - do k=1,nz - do j=js,je - do i=is,ie - h_tend = (h(i,j,k)-h_in(i,j,k))*stoch_CS%sppt_wts(i,j) - t_tend = (tv%T(i,j,k)-t_in(i,j,k))*stoch_CS%sppt_wts(i,j) - s_tend = (tv%S(i,j,k)-s_in(i,j,k))*stoch_CS%sppt_wts(i,j) - h_pert=h_tend+h_in(i,j,k) - t_pert=t_tend+t_in(i,j,k) - s_pert=s_tend+s_in(i,j,k) - if (h_pert > GV%Angstrom_H) then - h(i,j,k) = h_pert - else - h(i,j,k) = GV%Angstrom_H - endif - tv%T(i,j,k) = t_pert - if (s_pert > 0.0) then - tv%S(i,j,k) = s_pert - endif - enddo - enddo - enddo - deallocate(h_in) - deallocate(t_in) - deallocate(s_in) - endif - end subroutine diabatic @@ -579,8 +553,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. @@ -589,11 +561,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] real :: Idt ! The inverse time step [T-1 ~> s-1] - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m - - integer :: ig, jg ! global indices for testing testing itide point source (BDM) + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 @@ -1165,17 +1134,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. real :: Idt ! The inverse time step [T-1 ~> s-1] - integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz 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 @@ -1644,15 +1610,12 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] - dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 degC-1 ~> m3 kg-1 degC-1] - dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 ppt-1 ~> m3 kg-1 ppt-1]. u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] temp_diag, & ! Diagnostic array of previous temperatures [degC] saln_diag ! Diagnostic array of previous salinity [ppt] real, dimension(SZI_(G),SZJ_(G)) :: & - Rcv_ml, & ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges - SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL + Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & ! These are targets so that the space can be shared with eaml & ebml. @@ -1673,9 +1636,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Sadv_flx ! advective diapycnal salt flux across interfaces [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - real, allocatable, dimension(:,:) :: & - hf_dudt_dia_2d, hf_dvdt_dia_2d ! Depth sum of diapycnal mixing accelaration * fract. thickness [L T-2 ~> m s-2]. - ! The following 3 variables are only used with a bulk mixed layer. real, pointer, dimension(:,:,:) :: & eaml, & ! The equivalent of ea due to mixed layer processes [H ~> m or kg m-2]. @@ -1718,7 +1678,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e integer :: dir_flag ! An integer encoding the directions in which to do halo updates. logical :: showCallTree ! If true, show the call tree integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, m, halo + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb, halo 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 @@ -2220,7 +2180,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e endif ! diagnose temperature, salinity, heat, and salt tendencies - ! Note: hold here refers to the thicknesses from before the dual-entraintment when using + ! Note: hold here refers to the thicknesses from before the dual-entrainment when using ! the bulk mixed layer scheme, so tendencies should be posted on hold. if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, US, CS) @@ -2640,7 +2600,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks = 0.001 ! Conversion factor from g/kg to kg/kg. integer :: i, j, k, is, ie, js, je, nz - logical :: do_saln_tend ! Calculate salinity-based tendency diagnosics + logical :: do_saln_tend ! Calculate salinity-based tendency diagnostics is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 0.0 ; if (dt > 0.0) Idt = 1. / dt @@ -2933,7 +2893,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] - integer :: num_mode logical :: use_temperature character(len=20) :: EN1, EN2, EN3 @@ -3371,7 +3330,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%id_boundary_forcing_heat_tend = register_diag_field('ocean_model',& 'boundary_forcing_heat_tendency', diag%axesTL, Time, & 'Boundary forcing heat tendency', & - 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive = .true.) + 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) if (CS%id_boundary_forcing_heat_tend > 0) then CS%boundary_forcing_tendency_diag = .true. endif @@ -3425,7 +3384,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%frazil_tendency_diag = .true. endif - ! if all is working propertly, this diagnostic should equal to hfsifrazil + ! If all is working properly, this diagnostic should equal to hfsifrazil. CS%id_frazil_heat_tend_2d = register_diag_field('ocean_model',& 'frazil_heat_tendency_2d', diag%axesT1, Time, & 'Depth integrated heat tendency due to frazil formation', & diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 379275196e..f55f1e27a5 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -70,7 +70,7 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real :: ustar, absf, htot real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. real :: tmp1 ! A temporary array. - integer :: i, j, k, is, ie, js, je, nz, itt + 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 @@ -81,7 +81,7 @@ 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.5) then + 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 @@ -159,8 +159,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [degC] and [ppt]. Tf, Sf, & ! New final values of the temperatures and salinities [degC] and [ppt]. dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_a, dSe_a, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. - dTe_b, dSe_b, & ! Running (1-way) estimates of temperature and salinity change [degC] and [ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit ! mixing effects with other yet higher layers [degC H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -218,10 +216,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! accumulating the diffusivities [R Z L2 T-2 ~> J m-2]. ColHt_cor_k ! The correction to the potential energy change due to ! changes in the net column height [R Z L2 T-2 ~> J m-2]. - real :: & - b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: & - I_b1 ! The inverse of b1 [H ~> m or kg m-2]. + real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: Kd0 ! The value of Kddt_h that has already been applied [H ~> m or kg m-2]. 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 @@ -233,10 +228,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & 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]. - real :: dMKE_max ! The maximum amount of mean kinetic energy that could be - ! converted to turbulent kinetic energy if the velocity in - ! the layer below an interface were homogenized with all of - ! the water above the interface [R Z L2 T-2 ~> J m-2 = kg s-2]. real :: rho_here ! The in-situ density [R ~> kg m-3]. real :: PE_change ! The change in column potential energy from applying Kddt_h at the ! present interface [R L2 Z T-2 ~> J m-2]. @@ -259,9 +250,8 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: PE_chg_tot1D, PE_chg_tot2D, T_chg_totD real, dimension(GV%ke+1) :: dPEchg_dKd real :: PE_chg(6) - real, dimension(6) :: dT_k_itt, dS_k_itt, dT_km1_itt, dS_km1_itt - integer :: k, nz, itt, max_itt, k_cent + integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug logical :: old_PE_calc nz = GV%ke @@ -1281,11 +1271,9 @@ subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< structure to regulate diagnostic output type(diapyc_energy_req_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_diapyc_energy_req" ! This module's name. - character(len=256) :: mesg ! Message for error messages. if (.not.associated(CS)) then ; allocate(CS) else ; return ; endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 99dd38135d..c12921b1d9 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -16,8 +16,8 @@ module MOM_energetic_PBL use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_wave_interface, only: wave_parameters_CS, Get_Langmuir_Number -use MOM_stochastics, only : stochastic_CS +use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number +use MOM_stochastics, only : stochastic_CS implicit none ; private @@ -118,7 +118,7 @@ module MOM_energetic_PBL real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 !/ mstar_scheme == 3 - real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outter-most coefficient for fit). + real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit). !! Value of 0.275 in RH18. Increasing this !! coefficient increases mechanical mixing for all values of Hf/ust, !! but is most effective at low values (weakly developed OSBLs). @@ -140,18 +140,18 @@ module MOM_energetic_PBL !/ Langmuir turbulence related parameters logical :: Use_LT = .false. !< Flag for using LT in Energy calculation integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancment + real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of !! the mixed layer depth over the Ekman depth. real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with stablizing forcing. + !! the mixed layer depth over the Obukhov depth with stabilizing forcing. real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with stablizing forcing. + !! the Ekman depth over the Obukhov depth with stabilizing forcing. real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukov depth with destablizing forcing. + !! the mixed layer depth over the Obukhov depth with destabilizing forcing. real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukov depth with destablizing forcing. + !! the Ekman depth over the Obukhov depth with destabilizing forcing. real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing. !/ Others @@ -205,11 +205,11 @@ module MOM_energetic_PBL integer, parameter :: MStar_from_Ekman = 2 !< The value of mstar_scheme to base mstar on the ratio !! of the Ekman layer depth to the Obukhov depth integer, parameter :: MStar_from_RH18 = 3 !< The value of mstar_scheme to base mstar of of RH18 -integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbolence. +integer, parameter :: No_Langmuir = 0 !< The value of LT_ENHANCE_FORM not use Langmuir turbulence. integer, parameter :: Langmuir_rescale = 2 !< The value of LT_ENHANCE_FORM to use a multiplicative !! rescaling of mstar to account for Langmuir turbulence. integer, parameter :: Langmuir_add = 3 !< The value of LT_ENHANCE_FORM to add a contribution to - !! mstar from Langmuir turblence to other contributions. + !! mstar from Langmuir turbulence to other contributions. integer, parameter :: wT_from_cRoot_TKE = 0 !< Use a constant times the cube root of remaining TKE !! to calculate the turbulent velocity. integer, parameter :: wT_from_RH18 = 1 !< Use a scheme based on a combination of w* and v* as @@ -278,7 +278,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces !! [Z2 T-1 ~> m2 s-1]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence @@ -298,7 +298,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! mixing. ! ! The key parameters for the mixed layer are found in the control structure. -! To use the classic constant mstar mixied layers choose MSTAR_SCHEME=CONSTANT. +! To use the classic constant mstar mixed layers choose MSTAR_SCHEME=CONSTANT. ! The key parameters then include mstar, nstar, TKE_decay, and conv_decay. ! For the Oberhuber (1993) mixed layer,the values of these are: ! mstar = 1.25, nstar = 1, TKE_decay = 2.5, conv_decay = 0.5 @@ -329,7 +329,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & Kd, & ! The diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - mixvel, & ! A turbulent mixing veloxity [Z T-1 ~> m s-1]. + mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. mixlen ! A turbulent mixing length [Z ~> m]. 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]. @@ -390,7 +390,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! homogenizing the shortwave heating within that cell. This sets the energy ! and ustar and wstar available to drive mixing at the first interior ! interface. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz @@ -427,7 +427,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & - epbl1_wt=stoch_CS%epbl1_wts(i,j),epbl2_wt=stoch_CS%epbl2_wts(i,j)) + TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & @@ -450,7 +450,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%diag_TKE_conv_decay(i,j) = CS%diag_TKE_conv_decay(i,j) + eCD%dTKE_conv_decay ! CS%diag_TKE_unbalanced(i,j) = CS%diag_TKE_unbalanced(i,j) + eCD%dTKE_unbalanced endif - ! Write to 3-D for outputing Mixing length and velocity scale. + ! Write to 3-D for outputting Mixing length and velocity scale. if (CS%id_Mixing_Length>0) then ; do k=1,nz CS%Mixing_Length(i,j,k) = mixlen(k) enddo ; endif @@ -488,10 +488,11 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%id_LA > 0) call post_data(CS%id_LA, CS%LA, CS%diag) if (CS%id_LA_MOD > 0) call post_data(CS%id_LA_MOD, CS%LA_MOD, CS%diag) if (CS%id_MSTAR_LT > 0) call post_data(CS%id_MSTAR_LT, CS%MSTAR_LT, CS%diag) - if (stoch_CS%pert_epbl) then + if (stoch_CS%pert_epbl) then if (stoch_CS%id_epbl1_wts > 0) call post_data(stoch_CS%id_epbl1_wts, stoch_CS%epbl1_wts, CS%diag) if (stoch_CS%id_epbl2_wts > 0) call post_data(stoch_CS%id_epbl2_wts, stoch_CS%epbl2_wts, CS%diag) endif + end subroutine energetic_PBL @@ -500,7 +501,7 @@ end subroutine energetic_PBL !! mixed layer model for a single column of water. subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & - Waves, G, i, j, epbl1_wt, epbl2_wt) + Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) 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(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -535,12 +536,12 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !! [Z T-1 ~> m s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixlen !< The mixing length scale used in Kd [Z ~> m]. - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure type(ePBL_column_diags), intent(inout) :: eCD !< A container for passing around diagnostics. type(wave_parameters_CS), pointer :: Waves !< Waves control structure for Langmuir turbulence type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. - real, optional, intent(in) :: epbl1_wt !< random number to perturb KE generation - real, optional, intent(in) :: epbl2_wt !< random number to perturb KE dissipation + real, optional, intent(in) :: TKE_gen_stoch !< random factor used to perturb TKE generation [nondim] + real, optional, intent(in) :: TKE_diss_stoch !< random factor used to perturb TKE dissipation [nondim] integer, intent(in) :: i !< The i-index to work on (used for Waves) integer, intent(in) :: j !< The i-index to work on (used for Waves) @@ -610,7 +611,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! mixing effects with other yet lower layers [ppt H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & MixLen_shape, & ! A nondimensional shape factor for the mixing length that - ! gives it an appropriate assymptotic value at the bottom of + ! gives it an appropriate asymptotic value at the bottom of ! the boundary layer. Kddt_h ! The diapycnal diffusivity times a timestep divided by the ! average thicknesses around a layer [H ~> m or kg m-2]. @@ -691,7 +692,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real :: dKddt_h_Newt ! The change between guesses at Kddt_h(K) with Newton's method [H ~> m or kg m-2]. real :: Kddt_h_newt ! The Newton's method next guess for Kddt_h(K) [H ~> m or kg m-2]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. - real :: vstar_unit_scale ! A unit converion factor for turbulent velocities [Z T-1 s m-1 ~> 1] + real :: vstar_unit_scale ! A unit conversion factor for turbulent velocities [Z T-1 s m-1 ~> 1] logical :: use_Newt ! Use Newton's method for the next guess at Kddt_h(K). logical :: convectively_stable ! If true the water column is convectively stable at this interface. logical :: sfc_connected ! If true the ocean is actively turbulent from the present @@ -721,7 +722,6 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! can improve this. real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] - logical :: FIRST_OBL ! Flag for computing "found" Mixing layer depth logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter @@ -730,7 +730,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs logical :: debug ! This is used as a hard-coded value for debugging. ! The following arrays are used only for debugging purposes. - real :: dPE_debug, mixing_debug, taux2, tauy2 + real :: dPE_debug, mixing_debug real, dimension(20) :: TKE_left_itt, PE_chg_itt, Kddt_h_itt, dPEa_dKd_itt, MKE_src_itt real, dimension(SZK_(GV)) :: mech_TKE_k, conv_PErel_k, nstar_k real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [degC] @@ -831,8 +831,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs else mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif - ! stochastically pertrub mech_TKE in the UFS - if (present(epbl1_wt)) mech_TKE=mech_TKE*epbl1_wt + ! stochastically perturb mech_TKE in the UFS + if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch if (CS%TKE_diagnostics) then eCD%dTKE_conv = 0.0 ; eCD%dTKE_mixing = 0.0 @@ -915,8 +915,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & eCD%dTKE_mech_decay = eCD%dTKE_mech_decay + (exp_kh-1.0) * mech_TKE * I_dtdiag - if (present(epbl2_wt)) then ! perturb the TKE destruction - mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * epbl2_wt) + if (present(TKE_diss_stoch)) then ! perturb the TKE destruction + mech_TKE = mech_TKE * (1.0 + (exp_kh-1.0) * TKE_diss_stoch) else mech_TKE = mech_TKE * exp_kh endif @@ -990,7 +990,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! mixing at higher interfaces. It is an approximation to the more ! complete test dPEc_dKd_Kd0 >= 0.0, that would include the effects of ! mixing across interface K-1. The dT_to_dColHt here are effectively - ! mass-weigted estimates of dSV_dT. + ! mass-weighted estimates of dSV_dT. Convectively_stable = ( 0.0 <= & ( (dT_to_dColHt(k) + dT_to_dColHt(k-1) ) * (T0(k-1)-T0(k)) + & (dS_to_dColHt(k) + dS_to_dColHt(k-1) ) * (S0(k-1)-S0(k)) ) ) @@ -1076,7 +1076,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%wT_scheme==wT_from_cRoot_TKE) then vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - htot/MLD_guess) + Surface_Scale = max(0.05, 1.0 - htot * GV%H_to_Z / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) endif @@ -1125,7 +1125,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs if (CS%wT_scheme==wT_from_cRoot_TKE) then vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - htot/MLD_guess) + Surface_Scale = max(0.05, 1. - htot * GV%H_to_Z / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) endif @@ -1427,7 +1427,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs end subroutine ePBL_column !> 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, & @@ -1453,7 +1453,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! above, including implicit mixing effects with other !! yet higher layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Th_b !< An effective temperature times a thickness in the layer - !! below, including implicit mixfing effects with other + !! below, including implicit mixing effects with other !! yet lower layers [degC H ~> degC m or degC kg m-2]. real, intent(in) :: Sh_b !< An effective salinity times a thickness in the layer !! below, including implicit mixing effects with other @@ -1499,7 +1499,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h !! [R Z3 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 realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z3 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 Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -1522,7 +1522,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. @@ -1572,7 +1572,7 @@ 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 +!! for several changes in an interface'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, & @@ -1636,7 +1636,7 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h !! [R Z3 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 realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z3 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 Z3 T-2 H-1 ~> J m-3 or J kg-1]. @@ -1735,10 +1735,10 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] - real, intent(in) :: Abs_Coriolis !< abolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] - real, intent(out) :: Mstar !< Ouput mstar (Mixing/ustar**3) [nondim] + real, intent(out) :: Mstar !< Output mstar (Mixing/ustar**3) [nondim] real, optional, intent(in) :: Langmuir_Number !< Langmuir number [nondim] real, optional, intent(out) :: MStar_LT !< Mstar increase due to Langmuir turbulence [nondim] real, optional, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] @@ -1903,7 +1903,7 @@ end subroutine Mstar_Langmuir !> Copies the ePBL active mixed layer depth into MLD, in units of [Z ~> m] unless other units are specified. subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) - type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units @@ -1930,7 +1930,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic output - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure ! Local variables ! This include declares and sets the variable "version". @@ -2367,7 +2367,7 @@ end subroutine energetic_PBL_init !> Clean up and deallocate memory associated with the energetic_PBL module. subroutine energetic_PBL_end(CS) - type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control struct + type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control structure character(len=256) :: mesg real :: avg_its diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index fdc38ebf1e..45d442f98c 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -288,7 +288,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & enddo ; enddo endif - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index 9884eec7a2..3fca484349 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -112,7 +112,7 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) logical :: do_i(SZI_(G)) logical :: compute_h_old, compute_T_old - integer :: i, j, k, is, ie, js, je, nz, k2, i2 + integer :: i, j, k, is, ie, js, je, nz, k2 integer :: isj, iej, num_left, nkmb, k_tgt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -388,7 +388,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_any ! True if there is more to be done on the current j-row. logical :: calc_diags ! True if diagnostic tendencies are needed. - integer :: i, j, k, is, ie, js, je, nz, i2, isj, iej + integer :: i, j, k, is, ie, js, je, nz, isj, iej is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (present(halo)) then diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 300cdcbe1e..8a0a623c1a 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -103,7 +103,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) logical :: avg_enabled ! for testing internal tides (BDM) type(time_type) :: time_end !< For use in testing internal tides (BDM) - integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed + integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -185,7 +185,6 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) !! smooth out the values in thin layers [ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - type(int_tide_input_CS), pointer :: CS !< This module's control structure. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the !! ocean bottom [T-2 ~> s-2]. ! Local variables @@ -253,7 +252,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo @@ -301,12 +300,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(int_tide_input_type), pointer :: itide !< A structure containing fields related !! to the internal tide sources. ! Local variables - type(vardesc) :: vd logical :: read_tideamp ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. - character(len=20) :: tmpstr character(len=200) :: filename, tideamp_file, h2_file real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a44a7aee95..f0f958d49d 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -197,7 +197,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- ! Work on each column. !--------------------------------------- - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! call cpu_clock_begin(id_clock_setup) ! Store a transposed version of the initial arrays. ! Any elimination of massless layers would occur here. @@ -393,7 +393,6 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. - logical :: do_i ! If true, work on this column. integer, dimension(SZK_(GV)+1) :: kc ! The index map between the original ! interfaces and the interfaces with massless layers @@ -704,9 +703,6 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. integer :: ks_kappa, ke_kappa ! The k-range with nonzero kappas. - integer :: dt_halvings ! The number of times that the time-step is halved - ! in seeking an acceptable timestep. If none is - ! found, dt_rem*0.5^dt_halvings is used. integer :: dt_refinements ! The number of 2-fold refinements that will be used ! to estimate the maximum permitted time step. I.e., ! the resolution is 1/2^dt_refinements. @@ -1269,7 +1265,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin, Q_err_lin, TKE_src_norm + real :: K_err_lin, Q_err_lin real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 9aa8fafd14..d6d2e10393 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -110,9 +110,7 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ real :: inv_sw_pen_scale ! The inverse of the e-folding scale [Z-1 ~> m-1]. real :: Inv_nbands ! The inverse of the number of bands of penetrating ! shortwave radiation [nondim] - logical :: call_for_surface ! if horizontal slice is the surface layer real :: tmp(SZI_(G),SZJ_(G),SZK_(GV)) ! A 3-d temporary array for diagnosing opacity [Z-1 ~> m-1] - real :: chl(SZI_(G),SZJ_(G),SZK_(GV)) ! The concentration of chlorophyll-A [mg m-3]. real :: Pen_SW_tot(SZI_(G),SZJ_(G)) ! The penetrating shortwave radiation ! summed across all bands [Q R Z T-1 ~> W m-2]. real :: op_diag_len ! A tiny lengthscale [Z ~> m] used to remap diagnostics of opacity @@ -245,7 +243,6 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir ! radiation [Q R Z T-1 ~> W m-2]. real :: SW_nir_tot ! The sum across the near infrared bands of shortwave ! radiation [Q R Z T-1 ~> W m-2]. - type(time_type) :: day character(len=128) :: mesg integer :: i, j, k, n, is, ie, js, je, nz, nbands logical :: multiband_vis_input, multiband_nir_input, total_sw_input @@ -290,7 +287,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir if (present(chl_3d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_3d(i,j,1) ; enddo ; enddo do k=1,nz ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_3d(i,j,k) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_3d(i,j,k) < 0.0)) then write(mesg,'(" Negative chl_3d of ",(1pe12.4)," found at i,j,k = ", & & 3(1x,i3), " lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_3d(i,j,k), i, j, k, G%geoLonT(i,j), G%geoLatT(i,j) @@ -300,7 +297,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir elseif (present(chl_2d)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_2d(i,j) ; enddo ; enddo do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (chl_2d(i,j) < 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Negative chl_2d of ",(1pe12.4)," at i,j = ", & & 2(i3), "lon/lat = ",(1pe12.4)," E ", (1pe12.4), " N.")') & chl_data(i,j), i, j, G%geoLonT(i,j), G%geoLatT(i,j) @@ -316,7 +313,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_vis_tot,SW_nir_tot) do j=js,je ; do i=is,ie SW_vis_tot = 0.0 ; SW_nir_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_vis_tot = sw_vis_dir(i,j) + sw_vis_dif(i,j) elseif (total_sw_input) then @@ -344,7 +341,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir !$OMP parallel do default(shared) private(SW_pen_tot) do j=js,je ; do i=is,ie SW_pen_tot = 0.0 - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then if (multiband_vis_input) then SW_pen_tot = SW_pen_frac_morel(chl_data(i,j)) * (sw_vis_dir(i,j) + sw_vis_dif(i,j)) elseif (total_sw_input) then @@ -385,7 +382,7 @@ subroutine opacity_from_chl(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir case (MOREL_88) do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = CS%opacity_land_value - if (G%mask2dT(i,j) > 0.5) & + if (G%mask2dT(i,j) > 0.0) & optics%opacity_band(1,i,j,k) = US%Z_to_m * opacity_morel(chl_data(i,j)) do n=2,optics%nbands @@ -845,7 +842,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & logical :: SW_Remains ! If true, some column has shortwave radiation that ! was not entirely absorbed. - integer :: is, ie, nz, i, k, ks, n + integer :: is, ie, nz, i, k, n SW_Remains = .false. I_Habs = 1e3*GV%H_to_m ! optics%PenSW_absorb_Invlen @@ -962,7 +959,6 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] logical :: default_2018_answers - logical :: use_scheme integer :: isd, ied, jsd, jed, nz, n isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 1f141ffd0f..90cdd9d6e6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -87,11 +87,6 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct - ! Local variables - integer :: i, j, k, is, ie, js, je, nz - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -163,7 +158,6 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) h_prev_1d ! The previous thicknesses [H ~> m or kg m-2]. real :: I_dtol ! The inverse of the tolerance changes [nondim]. real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. - real :: h1, h2 ! Temporary thicknesses [H ~> m or kg m-2]. real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. real :: wt ! The weight of the filted interfaces in setting the targets [nondim]. real :: scale ! A scaling factor [nondim]. @@ -184,7 +178,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) logical :: cols_left, ent_any, more_ent_i(SZI_(G)), ent_i(SZI_(G)) logical :: det_any, det_i(SZI_(G)) - logical :: do_j(SZJ_(G)), do_i(SZI_(G)), find_i(SZI_(G)) + logical :: do_j(SZJ_(G)), do_i(SZI_(G)) logical :: debug = .false. logical :: fatal_error character(len=256) :: mesg ! Message for error messages. @@ -717,7 +711,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) #include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. - logical :: use_temperature logical :: default_2018_answers logical :: just_read integer :: isd, ied, jsd, jed diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 061fe776e1..fd7335fd0a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -503,7 +503,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. - if (CS%bottomdraglaw .and. (CS%BBL_effic>0.0)) then + if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int_2d, G, GV, US, CS, & dd%Kd_BBL, Kd_lay_2d) @@ -812,7 +812,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 i_rem = 0 @@ -907,7 +907,6 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & hb, & ! The thickness of the bottom layer [Z ~> m]. z_from_bot ! The hieght above the bottom [Z ~> m]. - real :: Rml_base ! density of the deepest variable density layer real :: dz_int ! thickness associated with an interface [Z ~> m]. real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. @@ -969,7 +968,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) @@ -1001,7 +1000,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 @@ -1195,7 +1194,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & do_diag_Kd_BBL = associated(Kd_BBL) - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return cdrag_sqrt = sqrt(CS%cdrag) TKE_Ray = 0.0 ; Rayleigh_drag = .false. @@ -1238,7 +1237,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 - do_i(i) = (G%mask2dT(i,j) > 0.5) + do_i(i) = (G%mask2dT(i,j) > 0.0) htot(i) = GV%H_to_Z*h(i,j,nz) rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) Rho_top(i) = GV%Rlay(1) @@ -1259,7 +1258,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (.not.domore) exit enddo ! k-loop - do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=nz-1,kb_min,-1 i_rem = 0 do i=is,ie ; if (do_i(i)) then @@ -1409,7 +1408,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real, parameter :: von_karm = 0.41 ! Von Karman constant (http://en.wikipedia.org/wiki/Von_Karman_constant) logical :: do_diag_Kd_BBL - if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic>0.0))) return + if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return do_diag_Kd_BBL = associated(Kd_BBL) N2_min = 0. @@ -1568,7 +1567,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, if (.not.CS%ML_radiation) return - do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.5) ; enddo + do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then @@ -1734,7 +1733,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) ! Determine ustar and the square magnitude of the velocity in the ! bottom boundary layer. Together these give the TKE source and ! vertical decay scale. - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. ; vhtot(i) = 0.0 ; htot(i) = 0.0 vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) else @@ -1775,7 +1774,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do i=is,ie ; if ((G%mask2dCv(i,J) > 0.5) .and. (htot(i) > 0.0)) then + do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then v2_bbl(i,J) = (vhtot(i)*vhtot(i))/(htot(i)*htot(i)) else v2_bbl(i,J) = 0.0 @@ -1783,7 +1782,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) enddo !$OMP do do j=js,je - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. ; uhtot(I) = 0.0 ; htot(I) = 0.0 ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) else @@ -1823,7 +1822,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo if (.not.domore) exit enddo - do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.5) .and. (htot(i) > 0.0)) then + do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then u2_bbl(I) = (uhtot(I)*uhtot(I))/(htot(I)*htot(I)) else u2_bbl(I) = 0.0 @@ -1984,7 +1983,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: TKE_to_Kd_used ! If true, TKE_to_Kd and maxTKE need to be calculated. - integer :: i, j, is, ie, js, je + integer :: is, ie, js, je integer :: isd, ied, jsd, jed if (associated(CS)) then diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index fb969953c4..761a77b399 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -385,15 +385,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (j 0) do_i(i) = .true. + do_i(i) = (G%mask2dCu(I,j) > 0.0) enddo else ! m=2 refers to v-points is = G%isc ; ie = G%iec do i=is,ie - do_i(i) = .false. - if (G%mask2dCv(i,J) > 0) do_i(i) = .true. + do_i(i) = (G%mask2dCv(i,J) > 0.0) enddo endif @@ -1807,9 +1805,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) end subroutine set_viscous_ML !> Register any fields associated with the vertvisc_type. -subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) +subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical @@ -1849,20 +1848,22 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & - "Shear-driven turbulent diffusivity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent diffusivity at interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & - "Shear-driven turbulent viscosity at interfaces", "m2 s-1", z_grid='i') + "Shear-driven turbulent viscosity at interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & - "Shear-driven turbulent viscosity at vertex interfaces", "m2 s-1", & - hor_grid="Bu", z_grid='i') + "Shear-driven turbulent viscosity at vertex interfaces", & + units="m2 s-1", conversion=US%Z2_T_to_m2_s, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -1882,7 +1883,7 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) if (MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & - "Instantaneous active mixing layer depth", "m") + "Instantaneous active mixing layer depth", "m", conversion=US%Z_to_m) endif if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then @@ -1924,17 +1925,16 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! to the representation in a restart file. real :: Z2_T_rescale ! A rescaling factor for vertical diffusivities and viscosities from the ! representation in a restart file to the internal representation in this run. - integer :: i, j, k, is, ie, js, je, n + integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz logical :: default_2018_answers - logical :: use_kappa_shear, adiabatic, use_omega, MLE_use_PBL_MLD + logical :: adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_KPP logical :: use_regridding ! If true, use the ALE algorithm rather than layered ! isopycnal or stacked shallow water mode. logical :: use_temperature ! If true, temperature and salinity are used as state variables. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. character(len=200) :: filename, tideamp_file - type(OBC_segment_type), pointer :: segment => NULL() ! pointer to OBC segment type ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_visc" ! This module's name. @@ -2191,9 +2191,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(visc%nkml_visc_u(IsdB:IedB,jsd:jed), source=0.0) allocate(visc%nkml_visc_v(isd:ied,JsdB:JedB), source=0.0) CS%id_nkml_visc_u = register_diag_field('ocean_model', 'nkml_visc_u', & - diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'm') + diag%axesCu1, Time, 'Number of layers in viscous mixed layer at u points', 'nondim') CS%id_nkml_visc_v = register_diag_field('ocean_model', 'nkml_visc_v', & - diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'm') + diag%axesCv1, Time, 'Number of layers in viscous mixed layer at v points', 'nondim') endif call register_restart_field_as_obsolete('Kd_turb','Kd_shear', restart_CS) @@ -2202,11 +2202,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! Account for possible changes in dimensional scaling for variables that have been ! read from a restart file. Z_rescale = 1.0 - if ((US%m_to_Z_restart /= 0.0) .and. (US%m_to_Z_restart /= US%m_to_Z)) & - Z_rescale = US%m_to_Z / US%m_to_Z_restart + if (US%m_to_Z_restart /= 0.0) Z_rescale = 1.0 / US%m_to_Z_restart I_T_rescale = 1.0 - if ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= US%s_to_T)) & - I_T_rescale = US%s_to_T_restart / US%s_to_T + if (US%s_to_T_restart /= 0.0) I_T_rescale = US%s_to_T_restart Z2_T_rescale = Z_rescale**2*I_T_rescale if (Z2_T_rescale /= 1.0) then diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index d0d64079c3..48e9320c8e 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -131,7 +131,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) & + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) & CS%num_col = CS%num_col + 1 enddo ; enddo @@ -143,7 +143,7 @@ subroutine initialize_sponge(Iresttime, int_height, G, param_file, CS, GV, & col = 1 do j=G%jsc,G%jec ; do i=G%isc,G%iec - if ((Iresttime(i,j)>0.0) .and. (G%mask2dT(i,j)>0)) then + if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) col = col +1 @@ -273,7 +273,6 @@ subroutine set_up_sponge_ML_density(sp_val, G, CS, sp_val_i_mean) !! layer density [R ~> kg m-3], for use if Iresttime_i_mean > 0. integer :: j, col - character(len=256) :: mesg ! String for error messages if (.not.associated(CS)) return diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index be574b4356..4728fefdff 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -875,7 +875,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! remap from input z coordinate to model coordinate: tidal_qe_md = 0.0 call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & - GV%ke, h_m, tidal_qe_md) + GV%ke, h_m, tidal_qe_md, GV%H_subroundoff, GV%H_subroundoff) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. @@ -1026,9 +1026,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) logical :: use_Polzin, use_Simmons - character(len=160) :: mesg ! The text of an error message integer :: i, k, is, ie, nz - integer :: a, fr, m is = G%isc ; ie = G%iec ; nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d384500c3d..4067f13757 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -13,7 +13,7 @@ module MOM_vert_friction use MOM_forcing_type, only : mech_forcing use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_SIMPLE, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init use MOM_PointAccel, only : PointAccel_CS @@ -256,7 +256,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do I=Isq,Ieq @@ -383,7 +383,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & !$OMP private(do_i,surface_stress,zDS,stress,h_a,hfr, & !$OMP b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo ! When mixing down Eulerian current + Stokes drift add before calling solver if (DoStokesMixing) then ; do k=1,nz ; do i=is,ie @@ -593,7 +593,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do j=G%jsc,G%jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do I=Isq,Ieq Ray(I,k) = visc%Ray_u(I,j,k) @@ -622,7 +622,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) ! Now find the meridional viscous remnant using the robust tridiagonal solver. !$OMP parallel do default(shared) firstprivate(Ray) private(do_i,b_denom_1,b1,d1,c1) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%Channel_drag) then ; do k=1,nz ; do i=is,ie Ray(i,k) = visc%Ray_v(i,J,k) @@ -766,7 +766,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & !$OMP firstprivate(i_hbbl) do j=G%Jsc,G%Jec - do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0) ; enddo + do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq kv_bbl(I) = visc%Kv_bbl_u(I,j) @@ -931,7 +931,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & !$OMP firstprivate(i_hbbl) do J=Jsq,Jeq - do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0) ; enddo + do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie kv_bbl(i) = visc%Kv_bbl_v(i,J) @@ -1626,7 +1626,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Local variables - real :: hmix_str_dflt real :: Kv_dflt ! A default viscosity [m2 s-1]. real :: Hmix_m ! A boundary layer thickness [m]. logical :: default_2018_answers diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 2d18b7c907..604751f4ef 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -156,18 +156,8 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field - real :: PI ! 3.1415926... calculated as 4*atan(1) real :: tr_y ! Initial zonally uniform tracer concentrations. 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]. @@ -370,8 +360,6 @@ end subroutine DOME_tracer_surface_state subroutine DOME_tracer_end(CS) type(DOME_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to DOME_register_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index 013b04a5b3..d6979f6ce4 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -163,18 +163,7 @@ subroutine initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! the sponges, if they are in use. Otherwise this !! may be unassociated. - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() 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]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -276,7 +265,6 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: melt(SZI_(G),SZJ_(G)) ! melt water (positive for melting, negative for freezing) [R Z T-1 ~> kg m-2 s-1] real :: mmax ! The global maximum melting rate [R Z T-1 ~> kg m-2 s-1] - character(len=256) :: mesg ! The text of an error message 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 @@ -354,7 +342,6 @@ end subroutine ISOMIP_tracer_surface_state subroutine ISOMIP_tracer_end(CS) type(ISOMIP_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to ISOMIP_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 7296f1d469..d83dc8a6c2 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -4,6 +4,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_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 @@ -14,6 +15,7 @@ module MOM_CFC_cap use MOM_io, only : vardesc, var_desc, query_vardesc, stdout use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_time_manager, only : time_type use time_interp_external_mod, only : init_external_field, time_interp_external use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -86,7 +88,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) real, dimension(:,:,:), pointer :: tr_ptr => NULL() character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. logical :: register_CFC_cap - integer :: isd, ied, jsd, jed, nz, m + integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -191,9 +193,6 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. - ! local variables - logical :: from_file = .false. - if (.not.associated(CS)) return CS%Time => day @@ -305,7 +304,7 @@ 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, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -341,14 +340,13 @@ end subroutine CFC_cap_column_physics !> Calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function CFC_cap_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -357,11 +355,6 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stock being sought. integer :: CFC_cap_stock !< The number of stocks calculated here. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke CFC_cap_stock = 0 if (.not.associated(CS)) return @@ -377,15 +370,8 @@ function CFC_cap_stock(h, stocks, G, GV, US, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="CFC_cap_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) CFC_cap_stock = 2 @@ -445,7 +431,7 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id 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, m, is, ie, js, je + integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -588,8 +574,6 @@ end subroutine comp_CFC_schmidt subroutine CFC_cap_end(CS) type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. - ! local variables - integer :: m if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 5fe55b896b..f7038b46f7 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -3,25 +3,28 @@ module MOM_OCMIP2_CFC ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data -use MOM_coupler_types, only : atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_hor_index, only : hor_index_type -use MOM_grid, only : ocean_grid_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : extract_coupler_type_data, set_coupler_type_data +use MOM_coupler_types, only : atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_hor_index, only : hor_index_type +use MOM_grid, only : ocean_grid_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, 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_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -105,7 +108,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers [various units by element]. character(len=48) :: flux_units ! The units for tracer fluxes. logical :: register_OCMIP2_CFC - integer :: isd, ied, jsd, jed, nz, m + integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -285,14 +288,14 @@ subroutine flux_init_OCMIP2_CFC(CS, verbosity) ! These calls obtain the indices for the CFC11 and CFC12 flux coupling. They ! can safely be called multiple times. ind_flux(1) = atmos_ocn_coupler_flux('cfc_11_flux', & - flux_type = 'air_sea_gas_flux', implementation='ocmip2', & + flux_type='air_sea_gas_flux', implementation='ocmip2', & param=(/ 9.36e-07, 9.7561e-06 /), & - ice_restart_file = default_ice_restart_file, & - ocean_restart_file = default_ocean_restart_file, & - caller = "register_OCMIP2_CFC", verbosity=verbosity) + ice_restart_file=default_ice_restart_file, & + ocean_restart_file=default_ocean_restart_file, & + caller="register_OCMIP2_CFC", verbosity=verbosity) ind_flux(2) = atmos_ocn_coupler_flux('cfc_12_flux', & flux_type='air_sea_gas_flux', implementation='ocmip2', & - param = (/ 9.36e-07, 9.7561e-06 /), & + param=(/ 9.36e-07, 9.7561e-06 /), & ice_restart_file=default_ice_restart_file, & ocean_restart_file=default_ocean_restart_file, & caller="register_OCMIP2_CFC", verbosity=verbosity) @@ -435,7 +438,7 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in unscaled units of CFC12_flux ! CFC concentrations times meters per second [CU R Z T-1 ~> CU kg m-2 s-1] 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, m, is, ie, js, je, nz, idim(4), jdim(4) + integer :: i, j, k, is, ie, js, je, nz, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -478,14 +481,13 @@ end subroutine OCMIP2_CFC_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function OCMIP2_CFC_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -494,11 +496,6 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stock being sought. integer :: OCMIP2_CFC_stock !< The number of stocks calculated here. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - real :: mass ! The cell volume or mass [H L2 ~> m3 or kg] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke OCMIP2_CFC_stock = 0 if (.not.associated(CS)) return @@ -514,15 +511,8 @@ function OCMIP2_CFC_stock(h, stocks, G, GV, US, CS, names, units, stock_index) call query_vardesc(CS%CFC12_desc, name=names(2), units=units(2), caller="OCMIP2_CFC_stock") units(1) = trim(units(1))//" kg" ; units(2) = trim(units(2))//" kg" - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 - stocks(1) = 0.0 ; stocks(2) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - mass = G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k) - stocks(1) = stocks(1) + CS%CFC11(i,j,k) * mass - stocks(2) = stocks(2) + CS%CFC12(i,j,k) * mass - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) - stocks(2) = stock_scale * stocks(2) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%CFC11, on_PE_only=.true.) + stocks(2) = global_mass_int_EFP(h, G, GV, CS%CFC12, on_PE_only=.true.) OCMIP2_CFC_stock = 2 @@ -553,7 +543,7 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, CS) real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. real :: sc_no_term ! A term related to the Schmidt number. - integer :: i, j, m, is, ie, js, je, idim(4), jdim(4) + integer :: i, j, is, ie, js, je, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec idim(:) = (/G%isd, is, ie, G%ied/) ; jdim(:) = (/G%jsd, js, je, G%jed/) @@ -609,7 +599,6 @@ subroutine OCMIP2_CFC_end(CS) ! This subroutine deallocates the memory owned by this module. ! Argument: CS - The control structure returned by a previous call to ! register_OCMIP2_CFC. - integer :: m if (associated(CS)) then if (associated(CS%CFC11)) deallocate(CS%CFC11) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index f8c0f6ac06..5eb286ce7d 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -29,7 +29,7 @@ module MOM_generic_tracer use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS - use MOM_coms, only : max_across_PEs, min_across_PEs, PE_here + use MOM_coms, only : EFP_type, max_across_PEs, min_across_PEs, PE_here use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, get_diag_time_end use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe @@ -40,7 +40,7 @@ module MOM_generic_tracer use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS - use MOM_spatial_means, only : global_area_mean + use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, set_time use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut @@ -109,7 +109,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir ! The directory where NetCDF input files are. ! These can be overridden later in via the field manager? - integer :: ntau, k,i,j,axes(3) + integer :: ntau, axes(3) type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name,longname,units real, dimension(:,:,:,:), pointer :: tr_field @@ -129,8 +129,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Register all the generic tracers used and create the list of them. !This can be called by ALL PE's. No array fields allocated. if (.not. g_registered) then - call generic_tracer_register() - g_registered = .true. + call generic_tracer_register() + g_registered = .true. endif @@ -188,29 +188,29 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) g_tracer=>CS%g_tracer_list do - call g_tracer_get_alias(g_tracer,g_tracer_name) - - call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) - call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) - call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) - - !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? - tr_ptr => tr_field(:,:,:,1) - ! Register prognastic tracer for horizontal advection, diffusion, and restarts. - if (g_tracer_is_prog(g_tracer)) then - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & - name=g_tracer_name, longname=longname, units=units, & - registry_diags=.false., & !### CHANGE TO TRUE? - restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) - else - call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & - restart_CS, longname=longname, units=units) - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + call g_tracer_get_alias(g_tracer,g_tracer_name) + + call g_tracer_get_pointer(g_tracer,g_tracer_name,'field',tr_field) + call g_tracer_get_values(g_tracer,g_tracer_name,'longname', longname) + call g_tracer_get_values(g_tracer,g_tracer_name,'units',units ) + + !!nnz: MOM field is 3D. Does this affect performance? Need it be override field? + tr_ptr => tr_field(:,:,:,1) + ! Register prognastic tracer for horizontal advection, diffusion, and restarts. + if (g_tracer_is_prog(g_tracer)) then + call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + name=g_tracer_name, longname=longname, units=units, & + registry_diags=.false., & !### CHANGE TO TRUE? + restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) + else + call register_restart_field(tr_ptr, g_tracer_name, .not.CS%tracers_may_reinit, & + restart_CS, longname=longname, units=units) + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer=>g_tracer_next enddo @@ -281,70 +281,70 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - if (g_tracer%requires_src_info ) then - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initializing generic tracer "//trim(g_tracer_name)//& - " using MOM_initialize_tracer_from_Z ") - - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = g_tracer%src_file, & - src_var_nam = g_tracer%src_var_name, & - src_var_unit_conversion = g_tracer%src_var_unit_conversion,& - src_var_record = g_tracer%src_var_record, & - src_var_gridspec = g_tracer%src_var_gridspec ) - - !Check/apply the bounds for each g_tracer - do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min - !Jasmin does not want to apply the maximum for now - !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max - endif - enddo ; enddo ; enddo - - !jgj: Reset CASED to 0 below K=1 - if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then - do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if (tr_ptr(i,j,k) /= CS%tracer_land_val) then - tr_ptr(i,j,k) = 0.0 - endif - enddo ; enddo ; enddo - endif - elseif(.not. g_tracer%requires_restart) then + if (g_tracer%requires_src_info ) then + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initializing generic tracer "//trim(g_tracer_name)//& + " using MOM_initialize_tracer_from_Z ") + + call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & + src_file = g_tracer%src_file, & + src_var_nam = g_tracer%src_var_name, & + src_var_unit_conversion = g_tracer%src_var_unit_conversion,& + src_var_record = g_tracer%src_var_record, & + src_var_gridspec = g_tracer%src_var_gridspec ) + + !Check/apply the bounds for each g_tracer + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + !Jasmin does not want to apply the maximum for now + !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + endif + enddo ; enddo ; enddo + + !jgj: Reset CASED to 0 below K=1 + if ( (trim(g_tracer_name) == 'cased') .or. (trim(g_tracer_name) == 'ca13csed') ) then + do k=2,nk ; do j=jsc,jec ; do i=isc,iec + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + tr_ptr(i,j,k) = 0.0 + endif + enddo ; enddo ; enddo + endif + elseif(.not. g_tracer%requires_restart) then !Do nothing for this tracer, it is initialized by the tracer package call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& "skip initialization of generic tracer "//trim(g_tracer_name)) - else !Do it old way if the tracer is not registered to start from a specific source file. + else !Do it old way if the tracer is not registered to start from a specific source file. !This path should be deprecated if all generic tracers are required to start from specified sources. - if (len_trim(CS%IC_file) > 0) then - ! Read the tracer concentrations from a netcdf file. - if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & - "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) - if (CS%Z_IC_file) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) - if (.not.OK) then - OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) - if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& - "Unable to read "//trim(g_tracer_name)//" from "//& - trim(CS%IC_file)//".") + if (len_trim(CS%IC_file) > 0) then + ! Read the tracer concentrations from a netcdf file. + if (.not.file_exists(CS%IC_file)) call MOM_error(FATAL, & + "initialize_MOM_Generic_tracer: Unable to open "//CS%IC_file) + if (CS%Z_IC_file) then + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, g_tracer_name, G, GV, US) + if (.not.OK) then + OK = tracer_Z_init(tr_ptr, h, CS%IC_file, trim(g_tracer_name), G, GV, US) + if (.not.OK) call MOM_error(FATAL,"initialize_MOM_Generic_tracer: "//& + "Unable to read "//trim(g_tracer_name)//" from "//& + trim(CS%IC_file)//".") + endif + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "initialized generic tracer "//trim(g_tracer_name)//& + " using Generic Tracer File on Z: "//CS%IC_file) + else + ! native grid + call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& + "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) + call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) endif - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "initialized generic tracer "//trim(g_tracer_name)//& - " using Generic Tracer File on Z: "//CS%IC_file) else - ! native grid - call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& - "Using Generic Tracer IC file on native grid "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - call MOM_read_data(CS%IC_file, trim(g_tracer_name), tr_ptr, G%Domain) + call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& + "check Generic Tracer IC filename "//trim(CS%IC_file)//& + " for tracer "//trim(g_tracer_name)) endif - else - call MOM_error(FATAL,"initialize_MOM_generic_tracer: "//& - "check Generic Tracer IC filename "//trim(CS%IC_file)//& - " for tracer "//trim(g_tracer_name)) - endif - endif + endif endif !traverse the linked list till hit NULL @@ -361,7 +361,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) > 0) then + if (G%mask2dT(i,j) > 0.0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = GV%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif @@ -459,21 +459,21 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (_ALLOCATED(g_tracer%trunoff)) then - call g_tracer_get_alias(g_tracer,g_tracer_name) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) - call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) - !nnz: Why is fluxes%river = 0? - runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & - US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) - stf_array = stf_array + runoff_tracer_flux_array - endif - - !traverse the linked list till hit NULL - call g_tracer_get_next(g_tracer, g_tracer_next) - if (.NOT. associated(g_tracer_next)) exit - g_tracer=>g_tracer_next + if (_ALLOCATED(g_tracer%trunoff)) then + call g_tracer_get_alias(g_tracer,g_tracer_name) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) + call g_tracer_get_pointer(g_tracer,g_tracer_name,'runoff_tracer_flux',runoff_tracer_flux_array) + !nnz: Why is fluxes%river = 0? + runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & + US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) + stf_array = stf_array + runoff_tracer_flux_array + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer => g_tracer_next enddo @@ -568,13 +568,12 @@ end subroutine MOM_generic_tracer_column_physics !! being requested specifically, returning the number of stocks it has !! calculated. If the stock_index is present, only the stock corresponding !! to that coded index is returned. - function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) + function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. character(len=*), dimension(:), intent(out) :: units !< The units of the stocks calculated. @@ -584,14 +583,12 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ !! number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] type(g_tracer_type), pointer :: g_tracer, g_tracer_next real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' - 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 + integer :: m MOM_generic_tracer_stock = 0 if (.not.associated(CS)) return @@ -605,7 +602,6 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 m=1 ; g_tracer=>CS%g_tracer_list do call g_tracer_get_alias(g_tracer,names(m)) @@ -613,12 +609,8 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_ units(m) = trim(units(m))//" kg" call g_tracer_get_pointer(g_tracer,names(m),'field',tr_field) - stocks(m) = 0.0 tr_ptr => tr_field(:,:,:,1) - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + tr_ptr(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, tr_ptr, on_PE_only=.true.) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) @@ -665,7 +657,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg real, dimension(:,:,:),pointer :: grid_tmask integer :: isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau - integer :: i, j, k, is, ie, js, je, m + integer :: k, is, ie, js, je, m real, allocatable, dimension(:) :: geo_z is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -755,7 +747,6 @@ subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, n real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array real :: tmax0, tmin0 ! First-guest values of tmax and tmin. integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - integer :: igmax, jgmax, kgmax, igmin, jgmin, kgmin real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema. ! arrays to enable vectorization @@ -859,7 +850,6 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke,1) :: rho0 real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke) :: dzt - type(g_tracer_type), pointer :: g_tracer !Set coupler values !nnz: fake rho0 @@ -892,9 +882,6 @@ end subroutine MOM_generic_tracer_surface_state subroutine MOM_generic_flux_init(verbosity) integer, optional, intent(in) :: verbosity !< A 0-9 integer indicating a level of verbosity. - integer :: ind - character(len=fm_string_len) :: g_tracer_name,longname, package,units,old_package,file_in,file_out - real :: const_init_value character(len=128), parameter :: sub_name = 'MOM_generic_flux_init' type(g_tracer_type), pointer :: g_tracer_list,g_tracer,g_tracer_next diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 4a98aa1934..d587ae5d6a 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -8,16 +8,17 @@ module MOM_lateral_boundary_diffusion use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_MODULE use MOM_checksums, only : hchksum -use MOM_domains, only : pass_var, sum_across_PEs +use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field use MOM_diag_vkernels, only : reintegrate_column -use MOM_error_handler, only : MOM_error, FATAL, is_root_pe +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_remapping, only : remapping_CS, initialize_remapping use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_spatial_means, only : global_mass_integral use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type @@ -78,7 +79,6 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, ! local variables character(len=80) :: string ! Temporary strings - integer :: ke, nk ! Number of levels in the LBD and native grids, respectively logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code if (ASSOCIATED(CS)) then @@ -125,7 +125,7 @@ logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction = .false., check_remapping = .false., answers_2018 = .false.) + check_reconstruction=.false., check_remapping=.false., answers_2018=.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.", & @@ -166,16 +166,13 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer - real, dimension(SZK_(GV)) :: tracer_1d !< 1d-array used to remap tracer change to native grid real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, !! only used to compute tendencies. - real, dimension(SZI_(G),SZJ_(G)) :: tracer_int !< integrated tracer before LBD is applied - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G)) :: tracer_end !< integrated tracer after LBD is applied. - !! [conc H L2 ~> conc m3 or conc kg] - integer :: i, j, k, m !< indices to loop over + 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 :: Idt !< inverse of the time step [T-1 ~> s-1] - real :: tmp1, tmp2 !< temporary variables [conc H L2 ~> conc m3 or conc kg] + character(len=256) :: mesg !< Message for error messages. + integer :: i, j, k, m !< indices to loop over call cpu_clock_begin(id_clock_lbd) Idt = 1./dt @@ -236,22 +233,11 @@ subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (CS%debug) then call hchksum(tracer%t, "after LBD "//tracer%name,G%HI) - tracer_int(:,:) = 0.0; tracer_end(:,:) = 0.0 - ! tracer (native grid) before and after LBD - do j=G%jsc,G%jec ; do i=G%isc,G%iec - do k=1,GV%ke - tracer_int(i,j) = tracer_int(i,j) + tracer_old(i,j,k) * & - (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) - tracer_end(i,j) = tracer_end(i,j) + tracer%t(i,j,k) * & - (h(i,j,k)*(G%mask2dT(i,j)*G%areaT(i,j))) - enddo - enddo; enddo - - tmp1 = SUM(tracer_int) - tmp2 = SUM(tracer_end) - call sum_across_PEs(tmp1) - call sum_across_PEs(tmp2) - if (is_root_pe()) write(*,*)'Total '//tracer%name//' before/after LBD:', tmp1, tmp2 + ! tracer (native grid) integrated tracer amounts before and after LBD + 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 + call MOM_mesg(mesg) endif ! Post the tracer diagnostics @@ -355,8 +341,8 @@ end subroutine swap !> Receives a 1D array x and sorts it into ascending order. subroutine sort(x, n) - real, dimension(n), intent(inout) :: x !< 1D array to be sorted integer, intent(in ) :: n !< # of pts in the array + real, dimension(n), intent(inout) :: x !< 1D array to be sorted ! local variables integer :: i, location @@ -394,9 +380,9 @@ subroutine unique(val, n, val_unique, val_max) max_val = MAXVAL(val) i = 0 do while (min_valmin_val) - tmp(i) = min_val + i = i+1 + min_val = MINVAL(val, mask=val>min_val) + tmp(i) = min_val enddo ii = i if (limit) then @@ -596,13 +582,14 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ 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 !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] - real :: khtr_avg !< Thickness-weighted diffusivity at the velocity-point [L2 T-1 ~> m2 s-1] - !! This is just to remind developers that khtr_avg should be - !! computed once khtr is 3D. real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k, k_bot_min, k_top_max !< k-indices, min and max for bottom and top, respectively - integer :: k_bot_max, k_top_min !< k-indices, max and min for bottom and top, respectively - integer :: k_bot_diff, k_top_diff !< different between left and right k-indices for bottom and top, respectively + integer :: k + 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 @@ -630,8 +617,10 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ allocate(F_layer_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(:)) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:)) + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_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) @@ -757,8 +746,8 @@ logical function near_boundary_unit_tests( verbose ) allocate(CS) ! fill required fields in CS CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation = .true. ,& - check_reconstruction = .true., check_remapping = .true.) + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& + check_reconstruction=.true., check_remapping=.true.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) CS%H_subroundoff = 1.0E-20 CS%debug=.false. @@ -1024,8 +1013,8 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans endif - 20 format(A,"=",i3,X,A,"=",i3) - 30 format(A,"=",f20.16,X,A,"=",f20.16) + 20 format(A,"=",i3,1X,A,"=",i3) + 30 format(A,"=",f20.16,1X,A,"=",f20.16) end function test_boundary_k_range diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index fd479eeaf3..f21bc9fa84 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -126,7 +126,6 @@ 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=256) :: mesg ! Message for error messages. character(len=80) :: string ! Temporary strings logical :: default_2018_answers logical :: boundary_extrap @@ -167,11 +166,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", CS%interior_only, & "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& - "boundary layers.", default = .false.) + "boundary layers.", default=.false.) 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 "//& - "recommended.", default = .false.) + "recommended.", default=.false.) ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then @@ -244,9 +243,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 -! call get_param(param_file, mdl, "KHTR", CS%KhTr, & -! "The background along-isopycnal tracer diffusivity.", & -! units="m2 s-1", default=0.0) ! call closeParameterBlock(param_file) if (CS%continuous_reconstruction) then CS%nsurf = 2*GV%ke+2 ! Continuous reconstruction means that every interface has two connections @@ -269,17 +265,17 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, allocate(CS%Pint(SZI_(G),SZJ_(G),SZK_(GV)+1), source=0.) allocate(CS%stable_cell(SZI_(G),SZJ_(G),SZK_(GV)), source=.true.) ! U-points - allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. - allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uPoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0. - allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoL(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%uKoR(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 - allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%uHeff(G%isc-1:G%iec,G%jsc:G%jec,:) = 0 + allocate(CS%uPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%uKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%uHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) ! V-points - allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vPoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0. - allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoL(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf)); CS%vKoR(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 - allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1)); CS%vHeff(G%isc:G%iec,G%jsc-1:G%jec,:) = 0 + allocate(CS%vPoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vPoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0.) + allocate(CS%vKoL(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vKoR(G%isd:G%ied,G%jsd:G%jed, CS%nsurf), source=0) + allocate(CS%vHeff(G%isd:G%ied,G%jsd:G%jed,CS%nsurf-1), source=0.) end function neutral_diffusion_init @@ -305,7 +301,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) 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, dimension(SZI_(G)) :: rho_tmp ! Routine to calculate drho_dp, returns density which is not used [R ~> kg m-3] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] integer, dimension(SZI_(G), SZJ_(G)) :: k_top ! Index of the first layer within the boundary real, dimension(SZI_(G), SZJ_(G)) :: zeta_top ! Distance from the top of a layer to the intersection of the @@ -328,7 +323,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) call pass_var(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.) then + 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)) endif enddo; enddo @@ -466,7 +461,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at U points do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) then + if (G%mask2dCu(I,j) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -487,7 +482,7 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Neutral surface factors at V points do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) then + if (G%mask2dCv(i,J) > 0.0) then if (CS%continuous_reconstruction) then call find_neutral_surface_positions_continuous(GV%ke, & CS%Pint(i,j,:), CS%Tint(i,j,:), CS%Sint(i,j,:), CS%dRdT(i,j,:), CS%dRdS(i,j,:), & @@ -522,10 +517,10 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) enddo ; enddo ; enddo else do k = 1, CS%nsurf-1 ; do j = G%jsc, G%jec ; do I = G%isc-1, G%iec - if (G%mask2dCu(I,j) > 0.) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H + if (G%mask2dCu(I,j) > 0.0) CS%uhEff(I,j,k) = CS%uhEff(I,j,k) * pa_to_H enddo ; enddo ; enddo do k = 1, CS%nsurf-1 ; do J = G%jsc-1, G%jec ; do i = G%isc, G%iec - if (G%mask2dCv(i,J) > 0.) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H + if (G%mask2dCv(i,J) > 0.0) CS%vhEff(i,J,k) = CS%vhEff(i,J,k) * pa_to_H enddo ; enddo ; enddo endif endif @@ -577,7 +572,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) 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 + 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 @@ -1254,7 +1249,6 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & logical :: searching_left_column ! True if searching for the position of a right interface in the left column logical :: searching_right_column ! True if searching for the position of a left interface in the right column logical :: reached_bottom ! True if one of the bottom-most interfaces has been used as the target - logical :: search_layer logical :: fail_heff ! Fail if negative thickness are encountered. By default this ! is true, but it can take its value from hard_fail_heff. real :: dRho ! A density difference between columns [R ~> kg m-3] @@ -1367,7 +1361,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & if (CS%debug) then write(stdout,'(A,I2)') "Searching left layer ", kl_left - write(stdout,'(A,I2,X,I2)') "Searching from right: ", kl_right, ki_right + write(stdout,'(A,I2,1X,I2)') "Searching from right: ", kl_right, ki_right write(stdout,*) "Temp/Salt Reference: ", Tr(kl_right,ki_right), Sr(kl_right,ki_right) write(stdout,*) "Temp/Salt Top L: ", Tl(kl_left,1), Sl(kl_left,1) write(stdout,*) "Temp/Salt Bot L: ", Tl(kl_left,2), Sl(kl_left,2) @@ -1390,7 +1384,7 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, & if (CS%debug) then write(stdout,'(A,I2)') "Searching right layer ", kl_right - write(stdout,'(A,I2,X,I2)') "Searching from left: ", kl_left, ki_left + write(stdout,'(A,I2,1X,I2)') "Searching from left: ", kl_left, ki_left write(stdout,*) "Temp/Salt Reference: ", Tl(kl_left,ki_left), Sl(kl_left,ki_left) write(stdout,*) "Temp/Salt Top L: ", Tr(kl_right,1), Sr(kl_right,1) write(stdout,*) "Temp/Salt Bot L: ", Tr(kl_right,2), Sr(kl_right,2) @@ -1449,7 +1443,7 @@ subroutine mark_unstable_cells(CS, nk, T, S, P, stable_cell) real, dimension(nk,2), intent(in) :: P !< Pressure at interfaces [R L2 T-2 ~> Pa] logical, dimension(nk), intent( out) :: stable_cell !< True if this cell is unstably stratified - integer :: k, first_stable, prev_stable + integer :: k real :: delta_rho ! A density difference [R ~> kg m-3] do k = 1,nk @@ -1536,7 +1530,6 @@ subroutine increment_interface(nk, kl, ki, reached_bottom, searching_this_column logical, intent(inout) :: reached_bottom !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_this_column !< Updated when kl == nk and ki == 2 logical, intent(inout) :: searching_other_column !< Updated when kl == nk and ki == 2 - integer :: k reached_bottom = .false. if (ki == 2) then ! At the bottom interface @@ -1599,7 +1592,6 @@ function find_neutral_pos_linear( CS, z0, T_ref, S_ref, dRdT_ref, dRdS_ref, & real :: S_z, dS_dz ! Salinity at a point and its derivative with fractional position [ppt] real :: drho_min, drho_max ! Bounds on density differences [R ~> kg m-3] real :: ztest, zmin, zmax ! Fractional positions in the cell [nondim] - real :: dz ! Change in position in the cell [nondim] real :: a1, a2 ! Fractional weights of the top and bottom values [nondim] integer :: iter integer :: nterm @@ -1796,7 +1788,6 @@ subroutine calc_delta_rho_and_derivs(CS, T1, S1, p1_in, T2, S2, p2_in, drho, & real :: p1, p2, pmid ! Pressures [R L2 T-2 ~> Pa] real :: drdt1, drdt2 ! Partial derivatives of density with temperature [R degC-1 ~> kg m-3 degC-1] real :: drds1, drds2 ! Partial derivatives of density with salinity [R ppt-1 ~> kg m-3 ppt-1] - real :: drdp1, drdp2 ! Partial derivatives of density with pressure [T2 L-2 ~> s2 m-2] ! Use the same reference pressure or the in-situ pressure if (CS%ref_pres > 0.) then @@ -1889,7 +1880,7 @@ function absolute_positions(n,ns,Pint,Karr,NParr) !! or other units following Pint ! Local variables - integer :: k_surface, k + integer :: k_surface do k_surface = 1, ns absolute_positions(k_surface) = absolute_position(n,ns,Pint,Karr,NParr,k_surface) @@ -1924,7 +1915,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K 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] ! Local variables - integer :: k_sublayer, klb, klt, krb, krt, k + 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 @@ -2115,15 +2106,11 @@ logical function ndiff_unit_tests_continuous(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 - real, dimension(nk+1) :: TiL, TiR1, TiR2, TiR4, Tio ! Test interface temperatures - real, dimension(nk) :: TL ! Test layer temperatures - real, dimension(nk+1) :: SiL ! Test interface salinities - real, dimension(nk+1) :: PiL, PiR4 ! Test interface positions - real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions - integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes - real, dimension(2*nk+1) :: hEff ! Test positions - real, dimension(2*nk+1) :: Flx ! Test flux - integer :: k + real, dimension(nk+1) :: Tio ! Test interface temperatures + real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions + integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes + real, dimension(2*nk+1) :: hEff ! Test positions + real, dimension(2*nk+1) :: Flx ! Test flux logical :: v real :: h_neglect @@ -2381,24 +2368,17 @@ logical function ndiff_unit_tests_discontinuous(verbose) ! Local variables integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 - real, dimension(nk) :: Sl, Sr, Tl, Tr ! Salinities [ppt] and temperatures [degC] + real, dimension(nk) :: Sl, Sr ! Salinities [ppt] and temperatures [degC] real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] integer, dimension(ns) :: KoL, KoR real, dimension(ns) :: PoL, PoR - real, dimension(ns-1) :: hEff, Flx + real, dimension(ns-1) :: hEff type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure - type(remapping_CS), pointer :: remap_CS !< Remapping control structure (PLM) real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S - real, dimension(nk,2) :: dRdT !< Partial derivative of density with temperature at - !! cell edges [R degC-1 ~> kg m-3 degC-1] - real, dimension(nk,2) :: dRdS !< Partial derivative of density with salinity at - !! cell edges [R ppt-1 ~> kg m-3 ppt-1] logical, dimension(nk) :: stable_l, stable_r - integer :: iMethod - integer :: ns_l, ns_r integer :: k logical :: v @@ -2654,9 +2634,9 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti if (test_fv_diff) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fv_diff) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2686,9 +2666,9 @@ logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue if (test_fvlsq_slope) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_fvlsq_slope) then - write(stdunit,'(2(x,a,f20.16),x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' + write(stdunit,'(2(1x,a,f20.16),1x,a)') 'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(2(x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue + write(stdunit,'(2(1x,a,f20.16))') 'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2716,10 +2696,10 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) if (test_ifndp) stdunit = stderr ! In case of wrong results, write to error stream write(stdunit,'(a)') title if (test_ifndp) then - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15),x,a)') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15),1x,a)') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue,'WRONG!' else - write(stdunit,'(4(x,a,f20.16),2(x,a,1pe22.15))') & + write(stdunit,'(4(1x,a,f20.16),2(1x,a,1pe22.15))') & 'r1=',rhoNeg,'p1=',Pneg,'r2=',rhoPos,'p2=',Ppos,'pRet=',Pret,'pTrue=',Ptrue endif endif @@ -2749,11 +2729,11 @@ logical function test_data1d(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1d = .true. - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15,x,a)') & + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15,1x,a)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,f20.16),x,a,1pe22.15)') & + write(stdunit,'(a,i2,2(1x,a,f20.16),1x,a,1pe22.15)') & 'k=',k,'Po=',Po(k),'Ptrue=',Ptrue(k),'err=',Po(k)-Ptrue(k) endif enddo @@ -2784,10 +2764,10 @@ logical function test_data1di(verbose, nk, Po, Ptrue, title) do k = 1,nk if (Po(k) /= Ptrue(k)) then test_data1di = .true. - write(stdunit,'(a,i2,2(x,a,i5),x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' + write(stdunit,'(a,i2,2(1x,a,i5),1x,a)') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k),'WRONG!' else if (verbose) & - write(stdunit,'(a,i2,2(x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) + write(stdunit,'(a,i2,2(1x,a,i5))') 'k=',k,'Io=',Po(k),'Itrue=',Ptrue(k) endif enddo endif diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index bdd6be4fe0..c0e10c2413 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -53,7 +53,7 @@ subroutine update_h_horizontal_flux(G, GV, uhtr, vhtr, h_pre, h_new) intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -88,7 +88,7 @@ subroutine update_h_vertical_flux(G, GV, ea, eb, h_pre, h_new) intent(inout) :: h_new !< Updated layer thicknesses [H ~> m or kg m-2] ! Local variables - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -139,7 +139,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) real :: hvol ! Cell volume [H L2 ~> m3 or kg] real :: scale_factor ! A nondimensional rescaling factor between 0 and 1 [nondim] real :: max_off_cfl ! The maximum permitted fraction that can leave in a timestep [nondim] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz max_off_cfl = 0.5 @@ -179,7 +179,7 @@ subroutine limit_mass_flux_3d(G, GV, uh, vh, ea, eb, h_pre) (max(0.0, -vh(i,J-1,k)) + max(0.0, vh(i,J,k)))) + & (max(0.0, top_flux(i,j,k)) + max(0.0, bottom_flux(i,j,k))) * G%areaT(i,j) - if (pos_flux>hvol .and. pos_flux>0.0) then + if ((pos_flux > hvol) .and. (pos_flux > 0.0)) then scale_factor = (hvol / pos_flux) * max_off_cfl else ! Don't scale scale_factor = 1.0 @@ -227,7 +227,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) real :: abs_uh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] real :: new_uh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] real :: uh_neglect ! A negligible transport [H L2 ~> m3 or kg] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -306,7 +306,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) real :: abs_vh_sum ! The vertical sum of the absolute value of the transports [H L2 ~> m3 or kg] real :: new_vh_sum ! The vertically summed transports after redistribution [H L2 ~> m3 or kg] real :: vh_neglect ! A negligible transport [H L2 ~> m3 or kg] - integer :: i, j, k, m, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -380,10 +380,10 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) real, dimension(SZIB_(G),SZK_(GV)) :: uh2d ! A slice of transports [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real :: uh_neglect, uh_remain, uh_add, uh_sum, uh_col, uh_max ! Transports [H L2 ~> m3 or kg] + real :: uh_neglect, uh_remain, uh_sum, uh_col ! Transports [H L2 ~> m3 or kg] real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -405,7 +405,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) do k=1,nz uh_remain = uh2d(I,k) uh2d(I,k) = 0.0 - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then do k_rev = k,1,-1 uh_sum = uh_remain + uh2d(I,k_rev) if (uh_sum<0.0) then ! Transport to the left @@ -436,7 +436,7 @@ subroutine distribute_residual_uh_upwards(G, GV, hvol, uh) enddo ! k_rev endif - if (abs(uh_remain)>0.0) then + if (abs(uh_remain) > 0.0) then if (k m3 or kg] - real, dimension(SZJB_(G)) :: vh2d_sum ! Summed transports [H L2 ~> m3 or kg] real, dimension(SZJ_(G),SZK_(GV)) :: h2d ! A slice of updated cell volumes [H L2 ~> m3 or kg] - real, dimension(SZJ_(G)) :: h2d_sum ! Summed cell volumes [H L2 ~> m3 or kg] real :: vh_neglect, vh_remain, vh_col, vh_sum ! Transports [H L2 ~> m3 or kg] real :: hup, hlos ! Various cell volumes [H L2 ~> m3 or kg] real :: min_h ! A minimal layer thickness [H ~> m or kg m-2] - integer :: i, j, k, m, is, ie, js, je, nz, k_rev + integer :: i, j, k, is, ie, js, je, nz, k_rev ! Set index-related variables for fields on T-grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -503,7 +501,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) do k=1,nz vh_remain = vh2d(J,k) vh2d(J,k) = 0.0 - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then do k_rev = k,1,-1 vh_sum = vh_remain + vh2d(J,k_rev) if (vh_sum<0.0) then ! Transport to the left @@ -535,7 +533,7 @@ subroutine distribute_residual_vh_upwards(G, GV, hvol, vh) enddo ! k_rev endif - if (abs(vh_remain)>0.0) then + if (abs(vh_remain) > 0.0) then if (k m or kg m-2] @@ -432,7 +431,7 @@ subroutine offline_redistribute_residual(CS, G, GV, US, h_pre, uhtr, vhtr, conve real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhr !< Remaining meridional mass transport [H L2 ~> m3 or kg] character(len=256) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz, iter + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iter real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] real :: prev_tot_residual, tot_residual ! The absolute value of the remaining transports [H L2 ~> m3 or kg] @@ -599,7 +598,7 @@ real function remaining_transport_sum(G, GV, US, uhtr, vhtr, h_new) intent(in ) :: uhtr !< Zonal mass transport [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in ) :: vhtr !< Meridional mass transport [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in ) :: h_new !< Layer thicknesses [H ~> m or kg m-2] ! Local variables @@ -862,16 +861,11 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, h_new, & ! Updated thicknesses [H ~> m or kg m-2] h_vol ! Cell volumes [H L2 ~> m3 or kg] ! Work arrays for temperature and salinity - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - temp_old, temp_mean, & ! Temperatures [degC] - salt_old, salt_mean ! Salinities [ppt] - integer :: niter, iter + integer :: iter real :: dt_iter ! The timestep of each iteration [T ~> s] real :: HL2_to_kg_scale ! Unit conversion factors to cell mass [kg H-1 L-2 ~> kg m-3 or 1] - logical :: converged character(len=160) :: mesg ! The text of an error message - integer :: i, j, k, m, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: isv, iev, jsv, jev ! The valid range of the indices. + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB logical :: z_first, x_before_y @@ -1317,7 +1311,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) character(len=20) :: redistribute_method ! This include declares and sets the variable "version". # include "version_variable.h" - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, nz integer :: IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1475,7 +1469,7 @@ subroutine read_all_input(CS, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - integer :: is, ie, js, je, isd, ied, jsd, jed, nz, t, ntime + integer :: isd, ied, jsd, jed, nz, t, ntime integer :: IsdB, IedB, JsdB, JedB nz = GV%ke ; ntime = CS%numtime diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index e8324b6043..7a2c64855f 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -38,18 +38,11 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] character(len=*), intent(in) :: filename !< The name of the file to read from character(len=*), intent(in) :: tr_name !< The name of the tracer in the file -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters real, optional, intent(in) :: missing_val !< The missing value for the tracer real, optional, intent(in) :: land_val !< A value to use to fill in land points - ! This function initializes a tracer by reading a Z-space file, returning true if this - ! appears to have been successful, and false otherwise. -! - integer, save :: init_calls = 0 ! This include declares and sets the variable "version". #include "version_variable.h" - character(len=40) :: mdl = "MOM_tracer_Z_init" ! This module's name. - character(len=256) :: mesg ! Message for error messages. real, allocatable, dimension(:,:,:) :: & tr_in ! The z-space array of tracer concentrations that is read in. @@ -299,7 +292,6 @@ subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, n ! Local variables real, dimension(nk_data) :: tr_1d !< a copy of the input tracer concentrations in a column. real, dimension(nlay+1) :: e_1d ! A 1-d column of intreface heights, in the same units as e. - real, dimension(nlay) :: tr_ ! A 1-d column of output tracer concentrations integer :: k_top, k_bot, k_bot_prev, kstart real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units. real, dimension(nk_data) :: wt !< The fractional weight for each layer in the range between z1 and z2 @@ -398,12 +390,12 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & ! This subroutine reads the vertical coordinate data for a field from a ! NetCDF file. It also might read the missing value attribute for that same field. character(len=32) :: mdl - character(len=120) :: dim_name, tr_msg, dim_msg + character(len=120) :: tr_msg, dim_msg character(:), allocatable :: edge_name character(len=256) :: dim_names(4) logical :: monotonic - integer :: ncid, status, intid, tr_id, layid, k - integer :: nz_edge, ndim, tr_dim_ids(8), sizes(4) + integer :: ncid, k + integer :: nz_edge, ndim, sizes(4) mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) @@ -599,7 +591,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, land_fill, h, real :: tol_rho ! The tolerance for density matches [R ~> kg m-3] real :: max_t_adj, max_s_adj integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, kz, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index e2c669fcc7..f946fd46c2 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -83,7 +83,6 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first optional, intent(out) :: vhr_out !< Remaining accumulated volume or mass fluxes !! through the meridional faces [H L2 ~> m3 or kg] - type(tracer_type) :: Tr(MAX_FIELDS_) ! The array of registered tracers real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & hprev ! cell volume at the end of previous tracer change [H L2 ~> m3 or kg] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & @@ -127,7 +126,6 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 ntr = Reg%ntr - do m=1,ntr ; Tr(m) = Reg%Tr(m) ; enddo Idt = 1.0 / dt max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 @@ -138,7 +136,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) do m=1,ntr - call create_group_pass(CS%pass_uhr_vhr_t_hprev, Tr(m)%t, G%Domain) + call create_group_pass(CS%pass_uhr_vhr_t_hprev, Reg%Tr(m)%t, G%Domain) enddo call cpu_clock_end(id_clock_pass) @@ -188,27 +186,11 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! initialize diagnostic fluxes and tendencies !$OMP do do m=1,ntr - if (associated(Tr(m)%ad_x)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%ad_x(I,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad_y)) then - do k=1,nz ; do J=jsd,jed ; do i=isd,ied - Tr(m)%ad_y(i,J,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%advection_xy)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - Tr(m)%advection_xy(i,j,k) = 0.0 - enddo ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_x)) then - do j=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_x(I,j) = 0.0 ; enddo ; enddo - endif - if (associated(Tr(m)%ad2d_y)) then - do J=jsd,jed ; do i=isd,ied ; Tr(m)%ad2d_y(i,J) = 0.0 ; enddo ; enddo - endif + if (associated(Reg%Tr(m)%ad_x)) Reg%Tr(m)%ad_x(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad_y)) Reg%Tr(m)%ad_y(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%advection_xy)) Reg%Tr(m)%advection_xy(:,:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_x)) Reg%Tr(m)%ad2d_x(:,:) = 0.0 + if (associated(Reg%Tr(m)%ad2d_y)) Reg%Tr(m)%ad2d_y(:,:) = 0.0 enddo !$OMP end parallel @@ -265,14 +247,14 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv-stencil, jev+stencil, k, G, GV, US, CS%usePPM, CS%useHuynh) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) ! Update domore_k(k) for the next iteration @@ -287,14 +269,14 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! First, advect meridionally. - call advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & + call advect_y(Reg%Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & isv-stencil, iev+stencil, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) endif ; enddo !$OMP do ordered do k=1,nz ; if (domore_k(k) > 0) then ! Next, advect zonally. - call advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & + call advect_x(Reg%Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & isv, iev, jsv, jev, k, G, GV, US, CS%usePPM, CS%useHuynh) ! Update domore_k(k) for the next iteration @@ -344,6 +326,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & is, ie, js, je, k, G, GV, US, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] @@ -355,7 +338,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & logical, dimension(SZJ_(G),SZK_(GV)), intent(inout) :: domore_u !< If true, there is more advection to be !! done in this u-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] - integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on @@ -373,8 +355,6 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real, dimension(SZI_(G),ntr) :: & T_tmp ! The copy of the tracer concentration at constant i,k [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: hup, hlos ! hup is the upwind volume, hlos is the ! part of that volume that might be lost ! due to advection out the other side of @@ -390,13 +370,19 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: tiny_h ! The smallest numerically invertible thickness [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 :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer concentration in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. - logical :: do_any_i + logical :: usePLMslope integer :: i, j, m, n, i_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - real :: fac1,u_L_in,u_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() - logical :: usePLMslope logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial ! keep a local copy of the initial values of domore_u, which is to be used when computing ad2d_x @@ -547,7 +533,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCu(I_up,j)*G%mask2dCu(I_up-1,j)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then @@ -709,6 +695,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & is, ie, js, je, k, G, GV, US, usePPM, useHuynh) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + integer, intent(in) :: ntr !< The number of tracers type(tracer_type), dimension(ntr), intent(inout) :: Tr !< The array of registered tracers to work on real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: hprev !< cell volume at the end of previous !! tracer change [H L2 ~> m3 or kg] @@ -720,7 +707,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical, dimension(SZJB_(G),SZK_(GV)), intent(inout) :: domore_v !< If true, there is more advection to be !! done in this v-row real, intent(in) :: Idt !< The inverse of dt [T-1 ~> s-1] - integer, intent(in) :: ntr !< The number of tracers integer, intent(in) :: is !< The starting tracer i-index to work on integer, intent(in) :: ie !< The ending tracer i-index to work on integer, intent(in) :: js !< The starting tracer j-index to work on @@ -737,8 +723,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & flux_y ! The tracer flux across a boundary [H L2 conc ~> m3 conc or kg conc]. real, dimension(SZI_(G),ntr,SZJB_(G)) :: & T_tmp ! The copy of the tracer concentration at constant i,k [conc]. - real :: maxslope ! The maximum concentration slope per grid point - ! consistent with monotonicity [conc]. real :: vhh(SZI_(G),SZJB_(G)) ! The meridional flux that occurs during the ! current iteration [H L2 ~> m3 or kg]. real :: hup, hlos ! hup is the upwind volume, hlos is the @@ -754,14 +738,20 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real :: tiny_h ! The smallest numerically invertible thickness [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 :: aR, aL ! Reconstructed tracer concentrations at the right and left edges [conc] + real :: dMx ! Difference between the maximum of the surrounding cell concentrations and + ! the value in the cell whose reconstruction is being found [conc] + real :: dMn ! Difference between the tracer average in the cell whose reconstruction + ! is being found and the minimum of the surrounding values [conc] + real :: Tp, Tc, Tm ! Tracer concentrations around the upstream cell [conc] + real :: dA ! Difference between the reconstruction tracer edge values [conc] + real :: mA ! Average of the reconstruction tracer edge values [conc] + real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. - logical :: do_any_i + logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil - real :: aR, aL, dMx, dMn, Tp, Tc, Tm, dA, mA, a6 - real :: fac1,v_L_in,v_L_out ! terms used for time-stepping OBC reservoirs type(OBC_segment_type), pointer :: segment=>NULL() - logical :: usePLMslope usePLMslope = .not. (usePPM .and. useHuynh) ! stencil for calculating slope values @@ -919,7 +909,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & dA = aR - aL ; mA = 0.5*( aR + aL ) if (G%mask2dCv(i,J_up)*G%mask2dCv(i,J_up-1)*(Tp-Tc)*(Tc-Tm) <= 0.) then - aL = Tc ; aR = Tc ! PCM for local extremum and bounadry cells + aL = Tc ; aR = Tc ! PCM for local extrema and boundary cells elseif ( dA*(Tc-mA) > (dA*dA)/6. ) then aL = 3.*Tc - 2.*aR elseif ( dA*(Tc-mA) < - (dA*dA)/6. ) then @@ -1080,8 +1070,6 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output type(tracer_advect_CS), pointer :: CS !< module control structure - integer, save :: init_calls = 0 - ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_advect" ! This module's name. diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index c865e645ad..4e067e6896 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -147,14 +147,14 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ea(i,j,k) + sink(i,K)) + & h_neglect @@ -164,7 +164,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ea(i,j,k) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ea(i,j,nz) + sink(i,nz)) + & h_neglect @@ -173,25 +173,25 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ea(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ea(i,j,1) b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = eb(i,j,k-1) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ea(i,j,k) @@ -199,7 +199,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ea(i,j,k) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = eb(i,j,nz-1) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ea(i,j,nz) @@ -207,7 +207,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ea(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -345,14 +345,14 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & enddo ! Now solve the tridiagonal equation for the tracer concentrations. - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then b_denom_1 = h_minus_dsink(i,1) + ent(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = b_denom_1 * b1(i) h_tr = h_old(i,j,1) + h_neglect tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) b_denom_1 = h_minus_dsink(i,k) + d1(i) * (ent(i,j,K) + sink(i,K)) + & h_neglect @@ -362,7 +362,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + & (ent(i,j,K) + sink(i,K)) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) b_denom_1 = h_minus_dsink(i,nz) + d1(i) * (ent(i,j,nz) + sink(i,nz)) + & h_neglect @@ -371,25 +371,25 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * ((h_tr * tr(i,j,nz) + btm_src(i,j)) + & (ent(i,j,nz) + sink(i,nz)) * tr(i,j,nz-1)) endif ; enddo - if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j)>0.5) then + if (present(btm_reservoir)) then ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then btm_reservoir(i,j) = btm_reservoir(i,j) + (sink(i,nz+1)*tr(i,j,nz)) * GV%H_to_RZ endif ; enddo ; endif - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo else !$OMP do do j=js,je - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then h_tr = h_old(i,j,1) + h_neglect b_denom_1 = h_tr + ent(i,j,1) b1(i) = 1.0 / (b_denom_1 + ent(i,j,2)) d1(i) = h_tr * b1(i) tr(i,j,1) = (b1(i)*h_tr)*tr(i,j,1) + b1(i)*sfc_src(i,j) endif ; enddo - do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=2,nz-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,k) = ent(i,j,K) * b1(i) h_tr = h_old(i,j,k) + h_neglect b_denom_1 = h_tr + d1(i) * ent(i,j,K) @@ -397,7 +397,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & d1(i) = b_denom_1 * b1(i) tr(i,j,k) = b1(i) * (h_tr * tr(i,j,k) + ent(i,j,K) * tr(i,j,k-1)) endif ; enddo ; enddo - do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then c1(i,nz) = ent(i,j,nz) * b1(i) h_tr = h_old(i,j,nz) + h_neglect b_denom_1 = h_tr + d1(i)*ent(i,j,nz) @@ -405,7 +405,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & tr(i,j,nz) = b1(i) * (( h_tr * tr(i,j,nz) + btm_src(i,j)) + & ent(i,j,nz) * tr(i,j,nz-1)) endif ; enddo - do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.5) then + do k=nz-1,1,-1 ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then tr(i,j,k) = tr(i,j,k) + c1(i,k+1)*tr(i,j,k+1) endif ; enddo ; enddo enddo @@ -465,7 +465,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim real :: hGrounding(maxGroundings) ! The remaining fresh water flux that was not able to be ! supplied from a column that grounded out [H ~> m or kg m-2] logical :: update_h - integer :: i, j, is, ie, js, je, k, nz, n, nsw + integer :: i, j, is, ie, js, je, k, nz character(len=45) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -635,7 +635,7 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim if (numberOfGroundings - maxGroundings > 0) then write(mesg, '(i4)') numberOfGroundings - maxGroundings call MOM_error(WARNING, "MOM_tracer_vertical.F90, applyTracerBoundaryFluxesInOut(): "//& - trim(mesg) // " groundings remaining") + trim(mesg) // " groundings remaining", all_print=.true.) endif endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 2ae72a3270..94e4b669ea 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -3,21 +3,22 @@ module MOM_tracer_flow_control ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type, assignment(=), EFP_to_real, real_to_EFP, EFP_sum_across_PEs use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file -use MOM_forcing_type, only : forcing, optics_type -use MOM_get_input, only : Get_MOM_input -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type +use MOM_file_parser, only : get_param, log_version, param_file_type, close_param_file +use MOM_forcing_type, only : forcing, optics_type +use MOM_get_input, only : Get_MOM_input +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : sponge_CS -use MOM_ALE_sponge, only : ALE_sponge_CS +use MOM_restart, only : MOM_restart_CS +use MOM_sponge, only : sponge_CS +use MOM_ALE_sponge, only : ALE_sponge_CS use MOM_tracer_registry, only : tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type #include ! Add references to other user-provide tracer modules here. @@ -123,7 +124,7 @@ subroutine call_tracer_flux_init(verbosity) type(param_file_type) :: param_file ! A structure to parse for run-time parameters character(len=40) :: mdl = "call_tracer_flux_init" ! This module's name. - logical :: use_OCMIP_CFCs, use_MOM_generic_tracer, use_CFC_caps + logical :: use_OCMIP_CFCs, use_MOM_generic_tracer ! Determine which tracer routines with tracer fluxes are to be called. Note ! that not every tracer package is required to have a flux_init call. @@ -582,8 +583,8 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock 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(:), intent(out) :: stock_values !< The integrated amounts of a tracer - !! on the current PE, usually in kg x concentration [kg conc]. + real, dimension(:), intent(out) :: stock_values !< The globally mass-integrated + !! amount of a tracer [kg conc]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to @@ -611,8 +612,10 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! Local variables character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name - real, dimension(MAX_FIELDS_) :: values - integer :: max_ns, ns_tot, ns, index, pkg, max_pkgs, nn + ! real, dimension(MAX_FIELDS_) :: values + type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP + type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP + integer :: max_ns, ns_tot, ns, index, nn, n if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -625,59 +628,59 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock ! Add other user-provided calls here. if (CS%use_USER_tracer_example) then - ns = USER_tracer_stock(h, values, G, GV, US, CS%USER_tracer_example_CSp, & + ns = USER_tracer_stock(h, values_EFP, G, GV, CS%USER_tracer_example_CSp, & names, units, stock_index) - call store_stocks("tracer_example", ns, names, units, values, index, stock_values, & + call store_stocks("tracer_example", ns, names, units, values_EFP, index, stock_val_EFP, & set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif ! if (CS%use_DOME_tracer) then ! ns = DOME_tracer_stock(h, values, G, GV, CS%DOME_tracer_CSp, & ! names, units, stock_index) -! call store_stocks("DOME_tracer", ns, names, units, values, index, stock_values, & +! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo +! call store_stocks("DOME_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & ! set_pkg_name, max_ns, ns_tot, stock_names, stock_units) ! endif if (CS%use_ideal_age) then - ns = ideal_age_stock(h, values, G, GV, US, CS%ideal_age_tracer_CSp, & + ns = ideal_age_stock(h, values_EFP, G, GV, CS%ideal_age_tracer_CSp, & names, units, stock_index) - call store_stocks("ideal_age_example", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("ideal_age_example", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_regional_dyes) then - ns = dye_stock(h, values, G, GV, US, CS%dye_tracer_CSp, & - names, units, stock_index) - call store_stocks("regional_dyes", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = dye_stock(h, values_EFP, G, GV, CS%dye_tracer_CSp, names, units, stock_index) + call store_stocks("regional_dyes", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_oil) then - ns = oil_stock(h, values, G, GV, US, CS%oil_tracer_CSp, & - names, units, stock_index) - call store_stocks("oil_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = oil_stock(h, values_EFP, G, GV, CS%oil_tracer_CSp, names, units, stock_index) + call store_stocks("oil_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_OCMIP2_CFC) then - ns = OCMIP2_CFC_stock(h, values, G, GV, US, CS%OCMIP2_CFC_CSp, names, units, stock_index) - call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = OCMIP2_CFC_stock(h, values_EFP, G, GV, CS%OCMIP2_CFC_CSp, names, units, stock_index) + call store_stocks("MOM_OCMIP2_CFC", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_CFC_cap) then - ns = CFC_cap_stock(h, values, G, GV, US, CS%CFC_cap_CSp, names, units, stock_index) - call store_stocks("MOM_CFC_cap", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ns = CFC_cap_stock(h, values_EFP, G, GV, CS%CFC_cap_CSp, names, units, stock_index) + call store_stocks("MOM_CFC_cap", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_advection_test_tracer) then - ns = advection_test_stock( h, values, G, GV, US, CS%advection_test_tracer_CSp, & + ns = advection_test_stock( h, values_EFP, G, GV, CS%advection_test_tracer_CSp, & names, units, stock_index ) - call store_stocks("advection_test_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + ! do n=1,ns ; values_EFP(n) = real_to_EFP(values(n)) ; enddo + call store_stocks("advection_test_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_MOM_generic_tracer) then - ns = MOM_generic_tracer_stock(h, values, G, GV, US, CS%MOM_generic_tracer_CSp, & + ns = MOM_generic_tracer_stock(h, values_EFP, G, GV, CS%MOM_generic_tracer_CSp, & names, units, stock_index) - call store_stocks("MOM_generic_tracer", ns, names, units, values, index, stock_values, & - set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("MOM_generic_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) nn=ns_tot-ns+1 nn=MOM_generic_tracer_min_max(nn, got_min_max, global_min, global_max, & xgmin, ygmin, zgmin, xgmax, ygmax, zgmax ,& @@ -685,20 +688,26 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock endif if (CS%use_pseudo_salt_tracer) then - ns = pseudo_salt_stock(h, values, G, GV, US, CS%pseudo_salt_tracer_CSp, & + ns = pseudo_salt_stock(h, values_EFP, G, GV, CS%pseudo_salt_tracer_CSp, & names, units, stock_index) - call store_stocks("pseudo_salt_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("pseudo_salt_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif if (CS%use_boundary_impulse_tracer) then - ns = boundary_impulse_stock(h, values, G, GV, US, CS%boundary_impulse_tracer_CSp, & + ns = boundary_impulse_stock(h, values_EFP, G, GV, CS%boundary_impulse_tracer_CSp, & names, units, stock_index) - call store_stocks("boundary_impulse_tracer", ns, names, units, values, index, & - stock_values, set_pkg_name, max_ns, ns_tot, stock_names, stock_units) + call store_stocks("boundary_impulse_tracer", ns, names, units, values_EFP, index, stock_val_EFP, & + set_pkg_name, max_ns, ns_tot, stock_names, stock_units) endif - if (ns_tot == 0) stock_values(1) = 0.0 + ! Sum the various quantities across all the processors. + if (ns_tot > 0) then + call EFP_sum_across_PEs(stock_val_EFP, ns_tot) + do n=1,ns_tot ; stock_values(n) = EFP_to_real(stock_val_EFP(n)) ; enddo + else + stock_values(1) = 0.0 + endif if (present(num_stocks)) num_stocks = ns_tot @@ -713,11 +722,13 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, intent(in) :: names !< Diagnostic names to use for each stock. character(len=*), dimension(:), & intent(in) :: units !< Units to use in the metadata for each stock. - real, dimension(:), intent(in) :: values !< The values of the tracer stocks + type(EFP_type), dimension(:), & + intent(in) :: values !< The values of the tracer stocks integer, intent(in) :: index !< The integer stock index from !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. - real, dimension(:), intent(inout) :: stock_values !< The master list of stock values + type(EFP_type), dimension(:), & + intent(inout) :: stock_values !< The master list of stock values character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose !! stocks were stored for a specific index. This is !! used to trigger an error if there are redundant stocks. diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 850480e3e6..24252dfedc 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -154,7 +154,6 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. real :: max_CFL ! The global maximum of the diffusive CFL number. logical :: use_VarMix, Resoln_scaled, do_online, use_Eady - integer :: S_idx, T_idx ! Indices for temperature and salinity if needed integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts real :: I_numitts ! The inverse of the number of iterations, num_itts. real :: scale ! The fraction of khdt_x or khdt_y that is applied in this @@ -174,7 +173,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") - if (LOC(Reg)==0) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + if (.not. associated(Reg)) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "register_tracer must be called before tracer_hordiff.") if (Reg%ntr == 0 .or. (CS%KhTr <= 0.0 .and. .not. VarMix%use_variable_mixing)) return @@ -692,7 +691,6 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & integer :: isd, ied, jsd, jed, IsdB, IedB, k_size integer :: kL, kR, kLa, kLb, kRa, kRb, nP, itt, ns, max_itt integer :: PEmax_kRho - integer :: isv, iev, jsv, jev ! The valid range of the indices. 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 @@ -728,7 +726,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) !$OMP parallel do default(shared) private(k_min,k_max,k_test) - do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.5) then + do j=js-2,je+2 ; do i=is-2,ie+2 ; if (G%mask2dT(i,j) > 0.0) then if ((Rml_max(i,j) > GV%Rlay(nz)) .or. (nkmb+1 > nz)) then ; max_kRho(i,j) = nz+1 elseif ((Rml_max(i,j) <= GV%Rlay(nkmb+1)) .or. (nkmb+2 > nz)) then ; max_kRho(i,j) = nkmb+1 else @@ -756,7 +754,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP parallel default(shared) private(ns,tmp,itmp) !$OMP do do j=js-1,je+1 - do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=1,nkmb ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if (h(i,j,k) > h_exclude) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -764,7 +762,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_srt(i,ns,j) = h(i,j,k) endif endif ; enddo ; enddo - do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.5) then + do k=nkmb+1,PEmax_kRho ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then if ((k<=k_end_srt(i,j)) .and. (h(i,j,k) > h_exclude)) then num_srt(i,j) = num_srt(i,j) + 1 ; ns = num_srt(i,j) k0_srt(i,ns,j) = k @@ -812,7 +810,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Set up the pairings for fluxes through the zonal faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -965,7 +963,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP kR,kL,nP,rho_pair,kbs_Lp,kbs_Rp,rho_a,rho_b, & !$OMP wt_b,left_set,right_set,h_supply_frac_R, & !$OMP h_supply_frac_L) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Set up the pairings for fluxes through the meridional faces. do k=1,num_srt(i,j) ; h_demand_L(k) = 0.0 ; h_used_L(k) = 0.0 ; enddo @@ -1120,7 +1118,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & !$OMP Tr_flux,Tr_adj_vert,wt_a,vol) - do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.5) then + do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Determine the fluxes through the zonal faces. ! Find the acceptable range of tracer concentration around this face. @@ -1260,7 +1258,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) - do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.5) then + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Determine the fluxes through the meridional faces. ! Find the acceptable range of tracer concentration around this face. @@ -1377,7 +1375,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP tr_flux_conv,Tr_flux_3d,k0a_Lv,Tr_adj_vert_L,& !$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & !$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) - do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.5) then + do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then do k=1,nPv(i,J) kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) if (deep_wt_Lv(J)%p(i,k) >= 1.0) then @@ -1402,7 +1400,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif ; enddo ; enddo !$OMP parallel do default(none) shared(PEmax_kRho,is,ie,js,je,G,h,Tr,tr_flux_conv,m) do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.5) .and. (h(i,j,k) > 0.0)) then + if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / & (h(i,j,k)*G%areaT(i,j)) tr_flux_conv(i,j,k) = 0.0 @@ -1444,7 +1442,6 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. - character(len=256) :: mesg ! Message for error messages. if (associated(CS)) then call MOM_error(WARNING, "tracer_hor_diff_init called with associated control structure.") @@ -1498,7 +1495,7 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_File, mdl, "RECALC_NEUTRAL_SURF", CS%recalc_neutral_surf, & "If true, then recalculate the neutral surfaces if the \n"//& "diffusive CFL is exceeded. If false, assume that the \n"//& - "positions of the surfaces do not change \n", default = .false.) + "positions of the surfaces do not change \n", default=.false.) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 2c77df3e74..821ac6a3cd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -367,7 +367,6 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE) character(len=120) :: cmor_longname ! The CMOR long name of that variable. character(len=120) :: var_lname ! A temporary longname for a diagnostic. character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic - character(len=72) :: cmor_varname ! The temporary CMOR name for a diagnostic type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m, m2, nTr_in integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 244eebb2bc..2921fdd124 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -172,16 +172,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & !! sponges, if they are in use. Otherwise this may be unassociated. real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() 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]. @@ -337,7 +328,6 @@ end subroutine RGC_tracer_column_physics subroutine RGC_tracer_end(CS) type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call to RGC_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 8fdb525b4a..441189c0ac 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -3,16 +3,18 @@ module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -75,8 +77,8 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "advection_test_tracer" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -180,23 +182,12 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() 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]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB - real :: tmpx, tmpy, locx, locy + real :: locx, locy if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -344,13 +335,12 @@ end subroutine advection_test_tracer_surface_state !> Calculate the mass-weighted integral of all tracer stocks, returning the number of stocks it has calculated. !! If the stock_index is present, only the stock corresponding to that coded index is returned. -function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function advection_test_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -359,8 +349,7 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde integer :: advection_test_stock !< the number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz, m + integer :: is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke advection_test_stock = 0 @@ -374,14 +363,9 @@ function advection_test_stock(h, stocks, G, GV, US, CS, names, units, stock_inde return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="advection_test_stock") - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo advection_test_stock = CS%ntr @@ -391,8 +375,6 @@ end function advection_test_stock subroutine advection_test_tracer_end(CS) type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_advection_test_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index ea60a09608..a4599a891e 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -3,24 +3,26 @@ module boundary_impulse_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, 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, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -73,9 +75,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re ! Local variables character(len=40) :: mdl = "boundary_impulse_tracer" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. - character(len=3) :: name_tag ! String for creating identifying boundary_impulse character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. ! This include declares and sets the variable "version". @@ -83,7 +83,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re real, pointer :: tr_ptr(:,:,:) => NULL() real, pointer :: rem_time_ptr => NULL() logical :: register_boundary_impulse_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then @@ -136,7 +136,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re rem_time_ptr => CS%remaining_source_time call register_restart_field(rem_time_ptr, "bir_remain_time", & .not.CS%tracers_may_reinit, restart_CS, & - "Remaining time to apply BIR source", "s") + "Remaining time to apply BIR source", "s", conversion=US%T_to_s) CS%tr_Reg => tr_Reg CS%restart_CSp => restart_CS @@ -167,11 +167,6 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, !! thermodynamic variables ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -194,8 +189,8 @@ subroutine initialize_boundary_impulse_tracer(restart, day, G, GV, US, h, diag, endif enddo ! Tracer loop - if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T /= US%s_to_T_restart) ) then - CS%remaining_source_time = (US%s_to_T / US%s_to_T_restart) * CS%remaining_source_time + if (restart .and. (US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0) ) then + CS%remaining_source_time = (1.0 / US%s_to_T_restart) * CS%remaining_source_time endif if (associated(OBC)) then @@ -243,10 +238,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real :: Isecs_per_year = 1.0 / (365.0*86400.0) - real :: year, h_total, scale, htot, Ih_limit - integer :: secs, days - integer :: i, j, k, is, ie, js, je, nz, m, k_max + integer :: i, j, k, is, ie, js, je, nz, m real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -268,7 +260,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if (CS%remaining_source_time>0.0) then + if (CS%remaining_source_time > 0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo @@ -287,13 +279,12 @@ end subroutine boundary_impulse_tracer_column_physics !> This function calculates the mass-weighted integral of the boundary impulse, !! tracer stocks returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function boundary_impulse_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in ) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in ) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent( out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent( out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. character(len=*), dimension(:), intent( out) :: names !< The names of the stocks calculated. @@ -302,14 +293,8 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in !! being sought. integer :: boundary_impulse_stock !< Return value: the number of stocks calculated here. -! This function calculates the mass-weighted integral of all tracer stocks, -! returning the number of stocks it has calculated. If the stock_index -! is present, only the stock corresponding to that coded index is returned. - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m boundary_impulse_stock = 0 if (.not.associated(CS)) return @@ -322,15 +307,10 @@ function boundary_impulse_stock(h, stocks, G, GV, US, CS, names, units, stock_in return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,1 call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="boundary_impulse_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo boundary_impulse_stock = CS%ntr @@ -374,8 +354,6 @@ end subroutine boundary_impulse_tracer_surface_state subroutine boundary_impulse_tracer_end(CS) type(boundary_impulse_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_boundary_impulse_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dca01e974a..a372faa518 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -3,6 +3,7 @@ module regional_dyes ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -13,6 +14,7 @@ module regional_dyes use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -74,13 +76,12 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! structure for the tracer advection and diffusion module. type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! Local variables -! This include declares and sets the variable "version". -#include "version_variable.h" + ! Local variables character(len=40) :: mdl = "regional_dyes" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. character(len=48) :: desc_name ! The variable's descriptor. + ! This include declares and sets the variable "version". +# include "version_variable.h" real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_dye_tracer integer :: isd, ied, jsd, jed, nz, m @@ -198,14 +199,8 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! for the sponges, if they are in use. ! Local variables - character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - logical :: OK integer :: i, j, k, m if (.not.associated(CS)) return @@ -271,12 +266,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: sfc_val ! The surface value for the tracers. - real :: Isecs_per_year ! The number of seconds in a year. - real :: year ! The time in years. real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] - integer :: secs, days ! Integer components of the time type. 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 @@ -325,13 +316,12 @@ end subroutine dye_tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function dye_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of - !! each tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(dye_tracer_CS), pointer :: CS !< The control structure returned by a !! previous call to register_dye_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -342,9 +332,7 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m dye_stock = 0 if (.not.associated(CS)) return @@ -357,15 +345,10 @@ function dye_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="dye_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo dye_stock = CS%ntr @@ -408,7 +391,6 @@ end subroutine dye_tracer_surface_state subroutine regional_dyes_end(CS) type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index b6bd212a37..b82bcf7fc6 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -143,18 +143,7 @@ subroutine initialize_dyed_obc_tracer(restart, day, G, GV, h, diag, OBC, CS) !! call to dyed_obc_register_tracer. ! Local variables - real, allocatable :: temp(:,:,:) - real, pointer, dimension(:,:,:) :: & - OBC_tr1_u => NULL(), & ! These arrays should be allocated and set to - OBC_tr1_v => NULL() ! specify the values of tracer 1 that should come - ! in through u- and v- points through the open - ! boundary conditions, in the same units as tr. character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() 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]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -253,7 +242,6 @@ end subroutine dyed_obc_tracer_column_physics subroutine dyed_obc_tracer_end(CS) type(dyed_obc_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to dyed_obc_register_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index d5c813b3d0..2fdeaff02f 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -3,6 +3,7 @@ module ideal_age_example ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, WARNING @@ -13,6 +14,7 @@ module ideal_age_example use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -78,8 +80,8 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !! diffusion module type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "ideal_age_example" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. @@ -215,11 +217,6 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS ! Local variables character(len=24) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. - character(len=72) :: cmorname ! The CMOR name of that variable. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -350,7 +347,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) endif do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.5) then + if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = sfc_val else CS%tr(i,j,k,m) = CS%land_val(m) @@ -369,14 +366,13 @@ end subroutine ideal_age_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it !! has calculated. If stock_index is present, only the stock corresponding to that coded index is found. -function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function ideal_age_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -386,9 +382,7 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: ideal_age_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m ideal_age_stock = 0 if (.not.associated(CS)) return @@ -401,15 +395,10 @@ function ideal_age_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="ideal_age_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo ideal_age_stock = CS%ntr @@ -453,8 +442,6 @@ subroutine ideal_age_example_end(CS) type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index 0e66ebbcf3..2ecd2ba6e0 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -58,10 +58,8 @@ logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restar ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "nw2_tracers" ! This module's name. - character(len=200) :: inputdir ! The directory where the input files are. character(len=8) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() - logical :: do_nw2 integer :: isd, ied, jsd, jed, nz, m, ig integer :: n_groups ! Number of groups of three tracers (i.e. # tracers/3) real, allocatable, dimension(:) :: timescale_in_days ! Damping timescale [days] @@ -301,8 +299,6 @@ subroutine nw2_tracers_end(CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracers. - integer :: m - if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) deallocate(CS) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 6f690ab760..900377fe83 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -3,24 +3,27 @@ module oil_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type, time_type_to_real +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type, time_type_to_real use MOM_tracer_registry, only : register_tracer, 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, thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_tracer_Z_init, only : tracer_Z_init +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface, thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -81,7 +84,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "oil_tracer" ! This module's name. -! This include declares and sets the variable "version". + ! This include declares and sets the variable "version". # include "version_variable.h" real, dimension(NTR_MAX) :: oil_decay_days !< Decay time scale of oil [days] character(len=200) :: inputdir ! The directory where the input files are. @@ -91,7 +94,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_oil_tracer - integer :: isd, ied, jsd, jed, nz, m, i, j + integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke if (associated(CS)) then @@ -217,10 +220,6 @@ subroutine initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables character(len=16) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for age tracer fluxes, either - ! years m3 s-1 or years kg s-1. logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -402,13 +401,12 @@ end subroutine oil_tracer_column_physics !> Calculate the mass-weighted integral of the oil tracer stocks, returning the number of stocks it !! has calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function oil_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. character(len=*), dimension(:), intent(out) :: names !< the names of the stocks calculated. @@ -418,9 +416,7 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: oil_stock !< The number of stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m oil_stock = 0 if (.not.associated(CS)) return @@ -433,15 +429,10 @@ function oil_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="oil_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo oil_stock = CS%ntr @@ -484,7 +475,6 @@ end subroutine oil_tracer_surface_state subroutine oil_tracer_end(CS) type(oil_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_oil_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index c441e519be..6c22daa150 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -3,6 +3,7 @@ module pseudo_salt_tracer ! 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 : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl @@ -14,6 +15,7 @@ module pseudo_salt_tracer use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type @@ -253,13 +255,12 @@ end subroutine pseudo_salt_tracer_column_physics !> Calculates the mass-weighted integral of all tracer stocks, returning the number of stocks it has !! calculated. If the stock_index is present, only the stock corresponding to that coded index is returned. -function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function pseudo_salt_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each !! tracer, in kg times concentration units [kg conc] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(pseudo_salt_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_pseudo_salt_tracer character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated @@ -269,10 +270,6 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) integer :: pseudo_salt_stock !< Return value: the number of !! stocks calculated here - ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - integer :: i, j, k, is, ie, js, je, nz - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pseudo_salt_stock = 0 if (.not.associated(CS)) return @@ -285,14 +282,9 @@ function pseudo_salt_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 call query_vardesc(CS%tr_desc, name=names(1), units=units(1), caller="pseudo_salt_stock") units(1) = trim(units(1))//" kg" - stocks(1) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(1) = stocks(1) + CS%diff(i,j,k) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(1) = stock_scale * stocks(1) + stocks(1) = global_mass_int_EFP(h, G, GV, CS%diff, on_PE_only=.true.) pseudo_salt_stock = 1 diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index a41f0ab76d..5d53c84df8 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -3,22 +3,25 @@ module USER_tracer_example ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : MOM_restart_CS -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : file_exists, MOM_read_data, slasher +use MOM_io, only : vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -64,8 +67,8 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Local variables character(len=80) :: name, longname -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "tracer_example" ! This module's name. character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually @@ -157,10 +160,6 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! Local variables real, allocatable :: temp(:,:,:) character(len=32) :: name ! A variable's name in a NetCDF file. - character(len=72) :: longname ! The long name of that variable. - character(len=48) :: units ! The dimensions of the variable. - character(len=48) :: flux_units ! The units for tracer fluxes, usually - ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. real, pointer :: tr_ptr(:,:,:) => NULL() real :: PI ! 3.1415926... calculated as 4*atan(1) real :: tr_y ! Initial zonally uniform tracer concentrations. @@ -246,7 +245,8 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & endif ! All tracers but the first have 0 concentration in their inflows. As this ! is the default value, the following calls are unnecessary. - do m=2,lntr + !do m=2,lntr + do m=2,ntr call query_vardesc(CS%tr_desc(m), name, caller="USER_initialize_tracer") ! Steal from updated DOME in the fullness of time. enddo @@ -358,14 +358,13 @@ end subroutine tracer_column_physics !> This function calculates the mass-weighted integral of all tracer stocks, !! returning the number of stocks it has calculated. If the stock_index !! is present, only the stock corresponding to that coded index is returned. -function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) +function USER_tracer_stock(h, stocks, G, GV, CS, names, units, stock_index) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(:), intent(out) :: stocks !< the mass-weighted integrated amount of each - !! tracer, in kg times concentration units [kg conc]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(EFP_type), dimension(:), intent(out) :: stocks !< The mass-weighted integrated amount of each + !! tracer, in kg times concentration units [kg conc] type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a !! previous call to register_USER_tracer. character(len=*), dimension(:), intent(out) :: names !< The names of the stocks calculated. @@ -376,9 +375,7 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) !! stocks calculated here. ! Local variables - real :: stock_scale ! The dimensional scaling factor to convert stocks to kg [kg H-1 L-2 ~> kg m-3 or 1] - 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 + integer :: m USER_tracer_stock = 0 if (.not.associated(CS)) return @@ -390,15 +387,10 @@ function USER_tracer_stock(h, stocks, G, GV, US, CS, names, units, stock_index) return endif ; endif - stock_scale = US%L_to_m**2 * GV%H_to_kg_m2 do m=1,NTR call query_vardesc(CS%tr_desc(m), name=names(m), units=units(m), caller="USER_tracer_stock") units(m) = trim(units(m))//" kg" - stocks(m) = 0.0 - do k=1,nz ; do j=js,je ; do i=is,ie - stocks(m) = stocks(m) + CS%tr(i,j,k,m) * (G%mask2dT(i,j) * G%areaT(i,j) * h(i,j,k)) - enddo ; enddo ; enddo - stocks(m) = stock_scale * stocks(m) + stocks(m) = global_mass_int_EFP(h, G, GV, CS%tr(:,:,:,m), on_PE_only=.true.) enddo USER_tracer_stock = NTR @@ -440,7 +432,6 @@ end subroutine USER_tracer_surface_state subroutine USER_tracer_example_end(CS) type(USER_tracer_example_CS), pointer :: CS !< The control structure returned by a previous !! call to register_USER_tracer. - integer :: m if (associated(CS)) then if (associated(CS%tr)) deallocate(CS%tr) diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6214f2d095..64fb31f68d 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -223,7 +223,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 70b4bbc27d..6c64ef5596 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -110,7 +110,6 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju ! positive upward, in depth units [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz real :: x - real :: delta_h real :: min_thickness real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay character(len=40) :: verticalCoordinate @@ -233,7 +232,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, integer :: i, j, k, is, ie, js, je, nz real :: x integer :: index_bay_z - real :: delta_S, delta_T + real :: delta_S real :: S_ref, T_ref ! Reference salinity and temperature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical real :: xi0, xi1 diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 248bf6c0f0..14899062b9 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -10,7 +10,7 @@ module DOME_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_tracer_registry, only : tracer_name_lookup @@ -100,7 +100,6 @@ subroutine DOME_initialize_thickness(h, depth_tot, G, GV, param_file, just_read) ! negative because it is positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. - character(len=40) :: mdl = "DOME_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -163,7 +162,6 @@ subroutine DOME_initialize_sponges(G, GV, US, tv, depth_tot, PF, CSp) real :: peak_damping ! The maximum sponge damping rates as the edges [days-1] real :: edge_dist ! The distance to an edge, in the same units as longitude [km] real :: sponge_width ! The width of the sponges, in the same units as longitude [km] - real :: e_dense ! The depth of the densest interfaces [Z ~> m] character(len=40) :: mdl = "DOME_initialize_sponges" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz @@ -301,7 +299,6 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, param_file, tr_Reg) ! in the same units as G%geoLon [km] real :: Ri_trans ! The shear Richardson number in the transition ! region of the specified shear profile [nondim] - character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. character(len=32) :: name ! The name of a tracer field. integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm integer :: IsdB, IedB, JsdB, JedB diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 7386a008e6..a67f3b09ed 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -145,12 +145,11 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv ! usually negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - integer :: i, j, k, is, ie, js, je, nz, tmp1 - real :: x + integer :: i, j, k, is, ie, js, je, nz real :: min_thickness, s_sur, s_bot, t_sur, t_bot real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: rho_range ! The range of densities [R ~> kg m-3] - character(len=256) :: mesg ! The text of an error message + !character(len=256) :: mesg ! The text of an error message character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -232,7 +231,7 @@ subroutine ISOMIP_initialize_thickness ( h, depth_tot, G, GV, US, param_file, tv case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo case default @@ -260,17 +259,15 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U !! only read parameters without changing T & S. ! Local variables integer :: i, j, k, is, ie, js, je, nz, itt - real :: x, ds, dt real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: xi0, xi1 ! Heights in depth units [Z ~> m]. real :: S_sur, S_bot ! Salinity at the surface and bottom [ppt] real :: T_sur, T_bot ! Temperature at the bottom [degC] real :: dT_dz ! Vertical gradient of temperature [degC Z-1 ~> degC m-1]. real :: dS_dz ! Vertical gradient of salinity [ppt Z-1 ~> ppt m-1]. - real :: z ! vertical position in z space [Z ~> m] - character(len=256) :: mesg ! The text of an error message - character(len=40) :: verticalCoordinate, density_profile - real :: rho_tmp + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + !real :: rho_tmp logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. real :: T0(SZK_(GV)) ! A profile of temperatures [degC] real :: S0(SZK_(GV)) ! A profile of salinities [ppt] @@ -450,8 +447,9 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: min_depth, dummy1, z - real :: rho_dummy, min_thickness, rho_tmp, xi0 + real :: min_depth, dummy1 + real :: min_thickness, xi0 + !real :: rho_tmp character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir @@ -574,7 +572,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / dfloat(nz)) + h(i,j,:) = GV%Z_to_H * (depth_tot(i,j) / real(nz)) enddo ; enddo case default diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 707a0972f9..d067b76eff 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -133,8 +133,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) units='Pa', default=96800., scale=US%m_s_to_L_T**2*US%kg_m3_to_R) call get_param(param_file, mdl, "IDL_HURR_RAD_MAX_WIND", & CS%rad_max_wind, "Radius of maximum winds used in the "//& - "idealized hurricane wind profile.", units='m', & - default=50.e3, scale=US%m_to_L) + "idealized hurricane wind profile.", & + units='m', default=50.e3, scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_MAX_WIND", CS%max_windspeed, & "Maximum wind speed used in the idealized hurricane"// & "wind profile.", units='m/s', default=65., scale=US%m_s_to_L_T) @@ -143,8 +143,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "hurricane wind profile.", units='m/s', default=5.0, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "IDL_HURR_TRAN_DIR", CS%hurr_translation_dir, & "Translation direction (towards) of hurricane used in the "//& - "idealized hurricane wind profile.", units='degrees', & - default=180.0, scale=CS%Deg2Rad) + "idealized hurricane wind profile.", & + units='degrees', default=180.0, scale=CS%Deg2Rad) call get_param(param_file, mdl, "IDL_HURR_X0", CS%Hurr_cen_X0, & "Idealized Hurricane initial X position", & units='m', default=0., scale=US%m_to_L) @@ -152,19 +152,17 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "Idealized Hurricane initial Y position", & units='m', default=0., scale=US%m_to_L) call get_param(param_file, mdl, "IDL_HURR_TAU_CURR_REL", CS%relative_tau, & - "Current relative stress switch "//& - "used in the idealized hurricane wind profile.", & - units='', default=.false.) + "Current relative stress switch used in the idealized hurricane wind profile.", & + default=.false.) ! Parameters for SCM mode call get_param(param_file, mdl, "IDL_HURR_SCM_BR_BENCH", CS%BR_BENCH, & "Single column mode benchmark case switch, which is "// & "invoking a modification (bug) in the wind profile meant to "//& - "reproduce a previous implementation.", units='', default=.false.) + "reproduce a previous implementation.", default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM", CS%SCM_MODE, & - "Single Column mode switch "//& - "used in the SCM idealized hurricane wind profile.", & - units='', default=.false.) + "Single Column mode switch used in the SCM idealized hurricane wind profile.", & + default=.false.) call get_param(param_file, mdl, "IDL_HURR_SCM_LOCY", CS%dy_from_center, & "Y distance of station used in the SCM idealized hurricane "//& "wind profile.", units='m', default=50.e3, scale=US%m_to_L) @@ -186,8 +184,8 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "GUST_CONST", CS%gustiness, & - "The background gustiness in the winds.", units="Pa", & - default=0.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z, do_not_log=.true.) + "The background gustiness in the winds.", & + units="Pa", default=0.0, scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, do_not_log=.true.) if (CS%BR_BENCH) then CS%rho_a = 1.2*US%kg_m3_to_R diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index d1c89f14f3..a65dc45e73 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -127,7 +127,6 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) ! Local variables character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. real :: min_depth ! The minimum and maximum depths [Z ~> m]. - real :: PI ! 3.1415... real :: coast_offset1, coast_offset2, coast_angle, right_angle integer :: i, j diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index d136d58a19..7583485ad7 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -427,8 +427,9 @@ function periodic_real(rval, num_period) result(val_out) !> This subroutine is used to allocate and register any fields in this module !! that should be written to or read from the restart file. -subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) +subroutine register_ctrl_forcing_restarts(G, US, param_file, CS, restart_CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure indicating the !! open file to parse for model !! parameter values. @@ -469,9 +470,11 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) allocate(CS%precip_0(isd:ied,jsd:jed), source=0.0) call register_restart_field(CS%heat_0, "Ctrl_heat", .false., restart_CS, & - longname="Control Integrative Heating", units="W m-2", z_grid='1') + longname="Control Integrative Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1') call register_restart_field(CS%precip_0, "Ctrl_precip", .false., restart_CS, & - longname="Control Integrative Precipitation", units="kg m-2 s-1", z_grid='1') + longname="Control Integrative Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1') endif if (CS%num_cycle > 0) then @@ -485,13 +488,16 @@ subroutine register_ctrl_forcing_restarts(G, param_file, CS, restart_CS) period_str = trim('p ')//trim(adjustl(period_str)) call register_restart_field(CS%heat_cyc, "Ctrl_heat_cycle", .false., restart_CS, & - longname="Cyclical Control Heating", units="W m-2", z_grid='1', t_grid=period_str) + longname="Cyclical Control Heating", & + units="W m-2", conversion=US%QRZ_T_to_W_m2, z_grid='1', t_grid=period_str) call register_restart_field(CS%precip_cyc, "Ctrl_precip_cycle", .false., restart_CS, & - longname="Cyclical Control Precipitation", units="kg m-2 s-1", z_grid='1', t_grid=period_str) + longname="Cyclical Control Precipitation", & + units="kg m-2 s-1", conversion=US%RZ_T_to_kg_m2s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_time, "avg_time", .false., restart_CS, & - longname="Cyclical accumulated averaging time", units="sec", z_grid='1', t_grid=period_str) + longname="Cyclical accumulated averaging time", & + units="sec", conversion=US%T_to_s, z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SST_anom, "avg_SST_anom", .false., restart_CS, & - longname="Cyclical average SST Anomaly", units="deg C", z_grid='1', t_grid=period_str) + longname="Cyclical average SST Anomaly", units="degC", z_grid='1', t_grid=period_str) call register_restart_field(CS%avg_SSS_anom, "avg_SSS_anom", .false., restart_CS, & longname="Cyclical average SSS Anomaly", units="g kg-1", z_grid='1', t_grid=period_str) endif @@ -592,11 +598,9 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) ! Rescale if there are differences between the dimensional scaling of variables in ! restart files from those in use for this run. if ((US%J_kg_to_Q_restart*US%kg_m3_to_R_restart*US%m_to_Z_restart*US%s_to_T_restart /= 0.0) .and. & - ((US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then + (US%s_to_T_restart /= US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then ! Redo the scaling of the corrective heat fluxes to [Q R Z T-1 ~> W m-2] - QRZ_T_rescale = (US%J_kg_to_Q * US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) + QRZ_T_rescale = US%s_to_T_restart / (US%J_kg_to_Q_restart * US%kg_m3_to_R_restart * US%m_to_Z_restart) if (associated(CS%heat_0)) then do j=jsc,jec ; do i=isc,iec @@ -612,11 +616,9 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) endif if ((US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T_restart /= 0.0) .and. & - ((US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) /= & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T)) ) then + (US%s_to_T_restart /= US%kg_m3_to_R_restart * US%m_to_Z_restart) ) then ! Redo the scaling of the corrective precipitation to [R Z T-1 ~> kg m-2 s-1] - RZ_T_rescale = (US%kg_m3_to_R * US%m_to_Z * US%s_to_T_restart) / & - (US%kg_m3_to_R_restart * US%m_to_Z_restart * US%s_to_T) + RZ_T_rescale = US%s_to_T_restart / (US%kg_m3_to_R_restart * US%m_to_Z_restart) if (associated(CS%precip_0)) then do j=jsc,jec ; do i=isc,iec @@ -632,10 +634,10 @@ subroutine controlled_forcing_init(Time, G, US, param_file, diag, CS) endif if ((CS%num_cycle > 0) .and. associated(CS%avg_time) .and. & - ((US%s_to_T_restart /= 0.0) .and. ((US%s_to_T_restart) /= US%s_to_T)) ) then + ((US%s_to_T_restart /= 0.0) .and. (US%s_to_T_restart /= 1.0)) ) then ! Redo the scaling of the accumulated times to [T ~> s] do m=1,CS%num_cycle - CS%avg_time(m) = (US%s_to_T / US%s_to_T_restart) * CS%avg_time(m) + CS%avg_time(m) = (1.0 / US%s_to_T_restart) * CS%avg_time(m) enddo endif diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a26bca4711..ab8a693ba4 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -241,10 +241,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call log_version(param_file, mdl, version) ! Langmuir number Options - call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) if (StatisticalWaves) then CS%WaveMethod = LF17 @@ -256,25 +256,25 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) ! Wave modified physics ! Presently these are all in research mode call get_param(param_file, mdl, "LAGRANGIAN_MIXING", CS%LagrangianMixing, & - "Flag to use Lagrangian Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Lagrangian Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%LagrangianMixing) then ! Force Code Intervention call MOM_error(FATAL,"Should you be enabling Lagrangian Mixing? Code not ready.") endif call get_param(param_file, mdl, "STOKES_MIXING", CS%StokesMixing, & - "Flag to use Stokes Mixing of momentum", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Stokes Mixing of momentum", default=.false., & + do_not_log=.not.use_waves) if (CS%StokesMixing) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Stokes Mixing? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Stokes Mixing? Code not ready.") endif call get_param(param_file, mdl, "CORIOLIS_STOKES", CS%CoriolisStokes, & - "Flag to use Coriolis Stokes acceleration", units="", & - Default=.false., do_not_log=.not.use_waves) + "Flag to use Coriolis Stokes acceleration", default=.false., & + do_not_log=.not.use_waves) if (CS%CoriolisStokes) then ! Force Code Intervention - call MOM_error(FATAL,"Should you be enabling Coriolis-Stokes? Code not ready.") + call MOM_error(FATAL, "Should you be enabling Coriolis-Stokes? Code not ready.") endif ! Get Wave Method and write to integer WaveMethod @@ -293,7 +293,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) " directly from WW3 and is based on the \n"// & " surface layer and projected Langmuir \n"// & " number (Li 2016)\n", & - units='', default=NULL_STRING) + default=NULL_STRING) select case (TRIM(TMPSTRING1)) case (NULL_STRING)! No Waves call MOM_error(FATAL, "wave_interface_init called with no specified "//& @@ -311,12 +311,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands CS%WaveMethod = SURFBANDS - call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & - "Choice of SURFACE_BANDS data mode, valid options include: \n"// & - " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"// & - " COUPLER - Look for variables from coupler pass \n"// & - " INPUT - Testing with fixed values.", & - units='', default=NULL_STRING) + call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & + "Choice of SURFACE_BANDS data mode, valid options include: \n"//& + " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& + " COUPLER - Look for variables from coupler pass \n"//& + " INPUT - Testing with fixed values.", default=NULL_STRING) select case (TRIM(TMPSTRING2)) case (NULL_STRING)! Default call MOM_error(FATAL, "wave_interface_init called with SURFACE_BANDS"//& @@ -328,10 +327,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) case (COUPLER_STRING)! Reserved for coupling CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. - call get_param(param_file,mdl,"STK_BAND_COUPLER",CS%NumBands, & - "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "// & - "This has to be consistent with the number of Stokes drift bands in WW3, "//& - "or the model will fail.",units='', default=1) + call get_param(param_file, mdl, "STK_BAND_COUPLER",CS%NumBands, & + "STK_BAND_COUPLER is the number of Stokes drift bands in the coupler. "//& + "This has to be consistent with the number of Stokes drift bands in WW3, "//& + "or the model will fail.", default=1) 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%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) @@ -341,11 +340,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) units='rad/m', default=0.12566, scale=US%Z_to_m) case (INPUT_STRING)! A method to input the Stokes band (globally uniform) CS%DataSource = INPUT - call get_param(param_file,mdl,"SURFBAND_NB",CS%NumBands, & - "Prescribe number of wavenumber bands for Stokes drift. "// & - "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "// & - "STOKES_Y, there are no safety checks in the code.", & - units='', default=1) + call get_param(param_file, mdl, "SURFBAND_NB", CS%NumBands, & + "Prescribe number of wavenumber bands for Stokes drift. "//& + "Make sure this is consistnet w/ WAVENUMBERS, STOKES_X, and "//& + "STOKES_Y, there are no safety checks in the code.", default=1) allocate( CS%WaveNum_Cen(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkX(1:CS%NumBands), source=0.0 ) allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) @@ -370,17 +368,15 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag ) call MOM_error(WARNING,"DHH85 only ever set-up for uniform cases w/"//& " Stokes drift in x-direction.") call get_param(param_file, mdl, "DHH85_AGE_FP", CS%WaveAgePeakFreq, & - "Choose true to use waveage in peak frequency.", & - units='', default=.false.) + "Choose true to use waveage in peak frequency.", default=.false.) call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & units='', default=1.2) - call get_param(param_file,mdl,"DHH85_WIND", CS%WaveWind, & + call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) - call get_param(param_file,mdl,"STATIC_DHH85", CS%StaticWaves, & - "Flag to disable updating DHH85 Stokes drift.", & - default=.false.) + call get_param(param_file, mdl, "STATIC_DHH85", CS%StaticWaves, & + "Flag to disable updating DHH85 Stokes drift.", default=.false.) case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 case (EFACTOR_STRING)!Li and Fox-Kemper 16 @@ -462,7 +458,7 @@ subroutine Update_Surface_Waves(G, GV, US, Day, dt, CS, forces) type(time_type), intent(in) :: dt !< Timestep as a time-type type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables - integer :: ii, jj, kk, b + integer :: ii, jj, b type(time_type) :: Day_Center ! Computing central time of time step @@ -1112,9 +1108,9 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: z0 ! The boundary layer depth [Z ~> m] real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] - real :: r5 ! A single expression that combines r3 and r4 [nondim] - real :: root_2kz ! The square root of twice the peak wavenumber times the - ! boundary layer depth [nondim] + ! real :: r5 ! A single expression that combines r3 and r4 [nondim] + ! real :: root_2kz ! The square root of twice the peak wavenumber times the + ! ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: PI ! 3.1415926535... diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 5d992b572f..19dc6af68a 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -41,8 +41,6 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) ! Local variables real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! real :: x, y ! This include declares and sets the variable "version". # include "version_variable.h" @@ -167,7 +165,6 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) real, intent(in) :: x0 !< x-position of line segment end[nondim] real, intent(in) :: x1 !< x-position of line segment end[nondim] real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y @@ -263,7 +260,7 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, real :: noise ! Noise type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. - integer :: i, j, k, k1, is, ie, js, je, nz, itt + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index db1b512ca9..7812f66f98 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -250,7 +250,7 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) logical :: reentrant_y ! If true, model is re-entrant in the y direction character(len=40) :: mdl = "Phillips_initialize_sponges" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: j, k, is, ie, js, je, isd, ied, jsd, jed, nz logical, save :: first_call = .true. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -265,8 +265,8 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) "The fractional depth where the stratificaiton is centered.", & units="nondim", default = 0.5) call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & - "The rate at which the zonal-mean sponges damp.", units="s-1", & - default = 1.0/(10.0*86400.0), scale=US%T_to_s) + "The rate at which the zonal-mean sponges damp.", & + units="s-1", default = 1.0/(10.0*86400.0), scale=US%T_to_s) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index b8eae3c704..1ac2169a7e 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -1,22 +1,9 @@ +!> Configures the models sponges for the Rotating Gravity Current (RGC) experiment. module RGC_initialization + +! This file is part of MOM6. See LICENSE.md for the license. + !*********************************************************************** -!* GNU General Public License * -!* This file is a part of MOM. * -!* * -!* MOM is free software; you can redistribute it and/or modify it and * -!* are expected to follow the terms of the GNU General Public License * -!* as published by the Free Software Foundation; either version 2 of * -!* the License, or (at your option) any later version. * -!* * -!* MOM is distributed in the hope that it will be useful, but WITHOUT * -!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY * -!* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public * -!* License for more details. * -!* * -!* For the full text of the GNU General Public License, * -!* write to: Free Software Foundation, Inc., * -!* 675 Mass Ave, Cambridge, MA 02139, USA. * -!* or see: http://www.gnu.org/licenses/gpl.html * !* By Elizabeth Yankovsky, May 2018 * !*********************************************************************** @@ -39,9 +26,13 @@ module RGC_initialization #include -character(len=40) :: mod = "RGC_initialization" ! This module's name. public RGC_initialize_sponges +! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional +! consistency testing. These are noted in comments with units like Z, H, L, and T, along with +! their mks counterparts with notation like "a velocity [Z T-1 ~> m s-1]". If the units +! vary with the Boussinesq approximation, the Boussinesq variant is given first. + contains !> Sets up the the inverse restoration time, and the values towards which the interface heights, @@ -61,66 +52,66 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C target, intent(in) :: v !< Array with the v velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: depth_tot !< The nominal total depth of the ocean [Z ~> m] - type(param_file_type), intent(in) :: PF !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode - type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure + type(param_file_type), intent(in) :: PF !< A structure to parse for model parameter values. + logical, intent(in) :: use_ALE !< If true, indicates model is in ALE mode + type(sponge_CS), pointer :: CSp !< Layer-mode sponge structure type(ALE_sponge_CS), pointer :: ACSp !< ALE-mode sponge structure -! Local variables - real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temp - real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salt + ! Local variables + real :: T(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for temperature [degC] + real :: S(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for salinity [ppt] real :: U1(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary array for u [L T-1 ~> m s-1] real :: V1(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary array for v [L T-1 ~> m s-1] - real :: RHO(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for RHO real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points + real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points [H ~> m or kg m-2] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] - real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [m]. + real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, positive upward [Z ~> m] logical :: sponge_uv ! Nudge velocities (u and v) towards zero - real :: min_depth, dummy1, z, delta_h - real :: rho_dummy, min_thickness, rho_tmp, xi0 - real :: lenlat, lenlon, lensponge + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: dummy1 ! The position relative to the sponge width [nondim] + real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) + real :: lenlat, lenlon ! The sizes of the domain [km] + real :: lensponge ! The width of the sponge [km] character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var - character(len=40) :: mod = "RGC_initialize_sponges" ! This subroutine's name. + character(len=40) :: mdl = "RGC_initialize_sponges" ! This subroutine's name. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, nz, iscB, iecB, jscB, jecB 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 iscB = G%iscB ; iecB = G%iecB; jscB = G%jscB ; jecB = G%jecB - call get_param(PF, mod,"MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & - units='m', default=1.e-3) + ! The variable min_thickness is unused, and can probably be eliminated. + call get_param(PF, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & + units='m', default=1.e-3, scale=GV%m_to_H) - call get_param(PF, mod, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & + call get_param(PF, mdl, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & units='days', default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mod, "LENLAT", lenlat, & + call get_param(PF, mdl, "LENLAT", lenlat, & "The latitudinal or y-direction length of the domain", & fail_if_missing=.true., do_not_log=.true.) - call get_param(PF, mod, "LENLON", lenlon, & + call get_param(PF, mdl, "LENLON", lenlon, & "The longitudinal or x-direction length of the domain", & fail_if_missing=.true., do_not_log=.true.) - call get_param(PF, mod, "LENSPONGE", lensponge, & + call get_param(PF, mdl, "LENSPONGE", lensponge, & "The length of the sponge layer (km).", & default=10.0) - call get_param(PF, mod, "SPONGE_UV", sponge_uv, & + call get_param(PF, mdl, "SPONGE_UV", sponge_uv, & "Nudge velocities (u and v) towards zero in the sponge layer.", & default=.false., do_not_log=.true.) - T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 ; RHO(:,:,:) = 0.0 + T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 - call get_param(PF, mod, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0) + call get_param(PF, mdl, "MINIMUM_DEPTH", min_depth, & + "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) if (associated(CSp)) call MOM_error(FATAL, & "RGC_initialize_sponges called with an associated control structure.") @@ -145,26 +136,21 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C ! 1) Read eta, salt and temp from IC file - call get_param(PF, mod, "INPUTDIR", inputdir, default=".") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - ! GM: get two different files, one with temp and one with salt values - ! this is work around to avoid having wrong values near the surface - ! because of the FIT_SALINITY option. To get salt values right in the - ! sponge, FIT_SALINITY=False. The oposite is true for temp. One can - ! combined the *correct* temp and salt values in one file instead. - call get_param(PF, mod, "RGC_SPONGE_FILE", state_file, & + call get_param(PF, mdl, "RGC_SPONGE_FILE", state_file, & "The name of the file with temps., salts. and interfaces to \n"// & " damp toward.", fail_if_missing=.true.) - call get_param(PF, mod, "SPONGE_PTEMP_VAR", temp_var, & + call get_param(PF, mdl, "SPONGE_PTEMP_VAR", temp_var, & "The name of the potential temperature variable in \n"//& "SPONGE_STATE_FILE.", default="Temp") - call get_param(PF, mod, "SPONGE_SALT_VAR", salt_var, & + call get_param(PF, mdl, "SPONGE_SALT_VAR", salt_var, & "The name of the salinity variable in \n"//& "SPONGE_STATE_FILE.", default="Salt") - call get_param(PF, mod, "SPONGE_ETA_VAR", eta_var, & + call get_param(PF, mdl, "SPONGE_ETA_VAR", eta_var, & "The name of the interface height variable in \n"//& "SPONGE_STATE_FILE.", default="eta") - call get_param(PF, mod, "SPONGE_H_VAR", h_var, & + call get_param(PF, mdl, "SPONGE_H_VAR", h_var, & "The name of the layer thickness variable in \n"//& "SPONGE_STATE_FILE.", default="h") @@ -176,12 +162,12 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain) if (use_ALE) then - call MOM_read_data(filename, h_var, h(:,:,:), G%Domain) + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=GV%m_to_H) call pass_var(h, G%domain) call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) - ! The remaining calls to set_up_sponge_field can be in any order. ! + ! The remaining calls to set_up_sponge_field can be in any order. if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp) if ( associated(tv%S) ) call set_up_ALE_sponge_field(S, G, GV, tv%S, ACSp) @@ -194,7 +180,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C else ! layer mode !read eta - call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z) ! Set the sponge damping rates so that the model will know where to ! apply the sponges, along with the interface heights. diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index c35386a2fe..53d57e99b7 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -120,9 +120,8 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, & integer :: i, j, k, is, ie, js, je, nz real :: T_ref, S_ref ! Reference salinity and temerature within surface layer real :: T_range ! Range of salinities and temperatures over the vertical - real :: y, zc, zi, dTdz + real :: zc, zi, dTdz character(len=40) :: verticalCoordinate - real :: PI ! 3.1415926... calculated as 4*atan(1) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -170,7 +169,6 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just logical, intent(in) :: just_read !< If present and true, this call will only !! read parameters without setting u & v. - real :: y ! Non-dimensional coordinate across channel, 0..pi real :: T_range ! Range of salinities and temperatures over the vertical real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 degC-1 ~> m s-1 degC-1] real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] @@ -219,7 +217,7 @@ real function yPseudo( G, lat ) type(ocean_grid_type), intent(in) :: G !< Grid structure real, intent(in) :: lat !< Latitude ! Local - real :: y, PI + real :: PI PI = 4.0 * atan(1.0) yPseudo = ( ( lat - G%south_lat ) / G%len_lat ) - 0.5 ! -1/2 .. 1/.2 diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 5bbe65b8d8..74cf31a22b 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -143,48 +143,39 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, 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, "SCM_USE_WIND_STRESS", & - CS%UseWindStress, "Wind Stress switch "// & - "used in the SCM CVMix surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", & - CS%UseHeatFlux, "Heat flux switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_EVAPORATION", & - CS%UseEvaporation, "Evaporation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) - call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", & - CS%UseDiurnalSW, "Diurnal sw radation switch "// & - "used in the SCM CVMix test surface forcing.", & - units='', default=.false.) + call get_param(param_file, mdl, "SCM_USE_WIND_STRESS", CS%UseWindStress, & + "Wind Stress switch used in the SCM CVMix surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_HEAT_FLUX", CS%UseHeatFlux, & + "Heat flux switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_EVAPORATION", CS%UseEvaporation, & + "Evaporation switch used in the SCM CVMix test surface forcing.", & + default=.false.) + call get_param(param_file, mdl, "SCM_USE_DIURNAL_SW", CS%UseDiurnalSW, & + "Diurnal sw radation switch used in the SCM CVMix test surface forcing.", & + default=.false.) if (CS%UseWindStress) then - call get_param(param_file, mdl, "SCM_TAU_X", & - CS%tau_x, "Constant X-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_X", CS%tau_x, & + "Constant X-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "SCM_TAU_Y", & - CS%tau_y, "Constant y-dir wind stress "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_TAU_Y", CS%tau_y, & + "Constant y-dir wind stress used in the SCM CVMix test surface forcing.", & units='N/m2', scale=US%kg_m2s_to_RZ_T*US%m_s_to_L_T, fail_if_missing=.true.) endif if (CS%UseHeatFlux) then - call get_param(param_file, mdl, "SCM_HEAT_FLUX", & - CS%surf_HF, "Constant surface heat flux "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_HEAT_FLUX", CS%surf_HF, & + "Constant surface heat flux used in the SCM CVMix test surface forcing.", & units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseEvaporation) then - call get_param(param_file, mdl, "SCM_EVAPORATION", & - CS%surf_evap, "Constant surface evaporation "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_EVAPORATION", CS%surf_evap, & + "Constant surface evaporation used in the SCM CVMix test surface forcing.", & units='m/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif if (CS%UseDiurnalSW) then - call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", & - CS%Max_sw, "Maximum diurnal sw radiation "// & - "used in the SCM CVMix test surface forcing.", & + call get_param(param_file, mdl, "SCM_DIURNAL_SW_MAX", CS%Max_sw, & + "Maximum diurnal sw radiation used in the SCM CVMix test surface forcing.", & units='m K/s', scale=US%m_to_Z*US%T_to_s, fail_if_missing=.true.) endif call get_param(param_file, mdl, "RHO_0", CS%Rho0, & diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 934536d1f8..96e80f970f 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -205,12 +205,11 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, integer :: i, j, k, is, ie, js, je, nz real :: x, y, yy - integer :: index_bay_z real :: S_ref, T_ref ! Reference salinity and temerature within ! surface layer real :: S_range, T_range ! Range of salinities and temperatures over the ! vertical - real :: xi0, xi1, dSdz, delta_S, delta_S_strat + real :: dSdz, delta_S, delta_S_strat real :: adjustment_width, adjustment_deltaS real :: front_wave_amp, front_wave_length, front_wave_asym real :: eta1d(SZK_(GV)+1) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index c9cdbfa392..9a4974807f 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -218,7 +218,6 @@ real function dist_line_fixed_y(x, y, x0, x1, y0) real, intent(in) :: x0 !< x-position of line segment end[nondim] real, intent(in) :: x1 !< x-position of line segment end[nondim] real, intent(in) :: y0 !< y-position of line segment [nondim] - real :: dx, yr, dy dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index d17be912ae..e042e245b7 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -238,7 +238,6 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3] real :: PI ! 3.1415926... calculated as 4*atan(1) real :: SST ! The initial sea surface temperature [degC] - character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 3bfdeaa0ff..c1ea771885 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -45,7 +45,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. real :: IC_amp ! The amplitude of the initial height displacement [H ~> m or kg m-2]. - real :: diskrad, rad, xCenter, xRadius, lonC, latC, xOffset + real :: diskrad, rad, lonC, latC, xOffset ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "circle_obcs_initialization" ! This module's name. diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index ac4181d570..7383373909 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -48,13 +48,13 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) ! Local variables integer :: i, j - real :: x, y, delta, dblen, dbfrac + real :: x, y, dblen, dbfrac logical :: dbrotate - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & + call get_param(param_file, mdl, "DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell.',& - units='k', default=600., do_not_log=.false.) - call get_param(param_file, mdl,"DUMBBELL_FRACTION",dbfrac, & + units='km', default=600., do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_FRACTION",dbfrac, & 'Meridional fraction for narrow part of dumbbell.',& units='nondim', default=0.5, do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & @@ -141,8 +141,8 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) ! Initial thicknesses for isopycnal coordinates - call get_param(param_file, mdl,"INITIAL_SSS", S_surf, default=34., do_not_log=.true.) - call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, default=34., do_not_log=.true.) + call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, default=2., do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, default = S_Ref, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, default = S_Ref, do_not_log=.true.) @@ -198,7 +198,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -217,10 +217,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file !! only read parameters without changing h. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range - real :: x, y, dblen - real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat + integer :: i, j, k, is, ie, js, je, nz + real :: S_surf, T_surf, S_range + real :: x, dblen logical :: dbrotate ! If true, rotate the domain. character(len=20) :: verticalCoordinate, density_profile @@ -230,23 +229,23 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"INITIAL_DENSITY_PROFILE", density_profile, & + call get_param(param_file, mdl, "INITIAL_DENSITY_PROFILE", density_profile, & 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_SREF", S_surf, & + call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', units='1e-3', default=34., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_S_RANGE", S_range, & - 'DUMBBELL salinity range (right-left)', units='1e-3', & - default=2., do_not_log=just_read) - call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & - 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & + 'DUMBBELL salinity range (right-left)', units='1e-3', default=2., & + do_not_log=just_read) + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & + 'Lateral Length scale for dumbbell ', & + units='km', default=600., do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & - 'Logical for rotation of dumbbell domain.',& + 'Logical for rotation of dumbbell domain.', & units='nondim', default=.false., do_not_log=just_read) if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + dblen = dblen*1.e3 endif do j=G%jsc,G%jec @@ -259,16 +258,16 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, param_file x = ( G%geoLonT(i,j) ) / dblen endif do k=1,nz - T(i,j,k)=T_surf + T(i,j,k) = T_surf enddo if (x>=0. ) then do k=1,nz - S(i,j,k)=S_surf + 0.5*S_range + S(i,j,k) = S_surf + 0.5*S_range enddo endif if (x<0. ) then do k=1,nz - S(i,j,k)=S_surf - 0.5*S_range + S(i,j,k) = S_surf - 0.5*S_range enddo endif @@ -293,17 +292,17 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use real :: sponge_time_scale ! The damping time scale [T ~> s] real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, T, S ! sponge thicknesses, temp and salt - real, dimension(SZK_(GV)+1) :: e0, eta1D ! interface positions for ALE sponge + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h, S ! sponge thicknesses, temp and salt + real, dimension(SZK_(GV)+1) :: eta1D ! interface positions for ALE sponge integer :: i, j, k, nz - real :: x, zi, zmid, dist, min_thickness, dblen - real :: mld, S_ref, S_range, S_dense, T_ref, sill_height + real :: x, min_thickness, dblen + real :: S_ref, S_range logical :: dbrotate ! If true, rotate the domain. call get_param(param_file, mdl,"DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell ',& - units='k', default=600., do_not_log=.true.) + units='km', default=600., do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& units='nondim', default=.false., do_not_log=.true.) @@ -378,12 +377,12 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use endif if (x>=0.25 ) then do k=1,nz - S(i,j,k)=S_ref + 0.5*S_range + S(i,j,k) = S_ref + 0.5*S_range enddo endif if (x<=-0.25 ) then do k=1,nz - S(i,j,k)=S_ref - 0.5*S_range + S(i,j,k) = S_ref - 0.5*S_range enddo endif enddo ; enddo diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index a1d8bf4b52..e97478b1a5 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -58,8 +58,6 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) type(dumbbell_surface_forcing_CS), pointer :: CS !< A control structure returned by a previous !! call to dumbbell_surface_forcing_init ! Local variables - real :: Temp_restore ! The temperature that is being restored toward [degC]. - real :: Salin_restore ! The salinity that is being restored toward [ppt]. integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -182,7 +180,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) ! Local variables real :: S_surf ! Initial surface salinity [ppt] real :: S_range ! Range of the initial vertical distribution of salinity [ppt] - real :: x, y ! Latitude and longitude normalized by the domain size [nondim] + real :: x ! Latitude normalized by the domain size [nondim] integer :: i, j logical :: dbrotate ! If true, rotate the domain. # include "version_variable.h" @@ -215,7 +213,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) units="Pa", default = 10000.0, scale=US%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & - units="days", default = 1.0) + units="days", default=1.0) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& units='nondim', default=.false., do_not_log=.true.) @@ -228,7 +226,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "given by FLUXCONST.", default=.false.) if (CS%restorebuoy) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index ff98f16529..411ab6ef98 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -8,7 +8,7 @@ module dyed_channel_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_open_boundary, only : OBC_registry_type, register_OBC use MOM_time_manager, only : time_type, time_type_to_real @@ -93,10 +93,8 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n - integer :: IsdB, IedB, JsdB, JedB + integer :: m, n real :: dye - type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & @@ -143,12 +141,10 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(time_type), intent(in) :: Time !< model time. ! Local variables - character(len=40) :: mdl = "dyed_channel_update_flow" ! This subroutine's name. - character(len=80) :: name real :: flow ! The OBC velocity [L T-1 ~> m s-1] real :: PI ! 3.1415926535... real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] - integer :: i, j, k, l, itt, isd, ied, jsd, jed, m, n + integer :: i, j, k, l, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 0307d93d3d..c5efef4905 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -8,7 +8,7 @@ module dyed_obcs_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_segment_type, register_segment_tracer use MOM_tracer_registry, only : tracer_registry_type, tracer_name_lookup use MOM_tracer_registry, only : tracer_type @@ -39,10 +39,9 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, n, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz integer :: IsdB, IedB, JsdB, JedB real :: dye - type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 27d0cedded..ec507e181b 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -53,8 +53,8 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SSH_ANOMALY_HEIGHT", ssh_anomaly_height, & - "The vertical displacement of the SSH anomaly. ", units="m", & - fail_if_missing=.not.just_read, do_not_log=just_read, scale=US%m_to_Z) + "The vertical displacement of the SSH anomaly. ", units="m", scale=US%m_to_Z, & + fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "SSH_ANOMALY_WIDTH", ssh_anomaly_width, & "The lateral width of the SSH anomaly. ", units="coordinate", & fail_if_missing=.not.just_read, do_not_log=just_read) diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index a61d07fcc8..a3418e6482 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -34,9 +34,6 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - real :: e0(SZK_(GV)) ! The resting interface heights [Z ~> m], usually - ! negative because it is positive upward. - real :: e_pert(SZK_(GV)) ! Interface height perturbations, positive upward [Z ~> m]. real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: front_displacement ! Vertical displacement acrodd front diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 3dba7bfe59..e15bcf4d4e 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -181,7 +181,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j case ( REGRIDDING_SIGMA ) ! Initial thicknesses for sigma coordinates if (just_read) return ! All run-time parameters have been read, so return. do j=js,je ; do i=is,ie - h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / dfloat(nz) + h(i,j,:) = GV%Z_to_H * depth_tot(i,j) / real(nz) enddo ; enddo end select @@ -201,7 +201,7 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, param_file, ! Local variables integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, dxi, r, S_surf, T_surf, S_range, T_range + real :: xi0, xi1, r, S_surf, T_surf, S_range, T_range real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat character(len=20) :: verticalCoordinate, density_profile diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 840f0bf3ed..3bb031bbb6 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -48,7 +48,7 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. logical :: register_shelfwave_OBC ! Local variables - real :: kk, ll, PI, len_lat + real :: PI, len_lat character(len=32) :: casename = "shelfwave" !< This case's name. @@ -144,8 +144,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] real :: alpha real :: x, y, jj, kk, ll - character(len=40) :: mdl = "shelfwave_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, n + integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 3bafdb2d02..6422f05855 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -78,7 +78,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, # include "version_variable.h" character(len=40) :: mdl = "sloshing_initialization" !< This module's name. - integer :: i, j, k, is, ie, js, je, nx, nz + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -189,7 +189,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz - real :: delta_S, delta_T + real :: delta_T real :: S_ref, T_ref; ! Reference salinity and temerature within ! surface layer real :: S_range, T_range; ! Range of salinities and temperatures over the diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index f62aa54f88..a203fb67de 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -40,7 +40,6 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) integer :: i, j, k, is, ie, js, je, nz real :: x, y, x0, y0 real :: val1, val2, val3, val4 - character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/supercritical_initialization.F90 b/src/user/supercritical_initialization.F90 index b4ceb1905d..ddb38a9cdf 100644 --- a/src/user/supercritical_initialization.F90 +++ b/src/user/supercritical_initialization.F90 @@ -7,7 +7,7 @@ module supercritical_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE, OBC_segment_type +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_segment_type use MOM_time_manager, only : time_type, time_type_to_real use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 2438b4115a..d25ad0615c 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -70,8 +70,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: PI real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] - character(len=40) :: mdl = "tidal_bay_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, nz, n + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 0308a3b008..f0ed674cf9 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -77,8 +77,6 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i integer :: i, j, k, is, ie, js, je, nz integer :: isd, ied, jsd, jed - real :: kappa_fill ! diffusivity used to fill massless layers - real :: dt_fill ! timestep used to fill massless layers character(len=200) :: mesg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -205,11 +203,10 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) !! point to the control !! structure for this module. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "user_set_diffusivity" ! This module's name. character(len=200) :: mesg - integer :: i, j, is, ie, js, je if (associated(CS)) then call MOM_error(WARNING, "diabatic_entrain_init called with an associated "// & @@ -219,17 +216,13 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) allocate(CS) CS%initialized = .true. - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - CS%diag => diag ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & "A user-specified additional diffusivity over a range of "//& - "latitude and density.", default=0.0, units="m2 s-1", & - scale=US%m2_s_to_Z2_T) + "latitude and density.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & "Four successive values that define a range of latitudes "//& diff --git a/src/user/user_initialization.F90 b/src/user/user_initialization.F90 index d59d271471..adccc40b81 100644 --- a/src/user/user_initialization.F90 +++ b/src/user/user_initialization.F90 @@ -8,7 +8,7 @@ module user_initialization use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_SIMPLE +use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N use MOM_open_boundary, only : OBC_DIRECTION_S use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS